Compare Sheet1 and Sheet2 for every match and then write them on Sheet3 I have the following code

Sub checkdata()
Application.Calculation = xlCalculationManual
Dim sheet1 As Worksheet
Set sheet1 = Sheets(1)
Dim sheet2 As Worksheet
Set sheet2 = Sheets(2)
Dim sheet3 As Worksheet
Set sheet3 = Sheets(3)
lr1 = sheet1.Cells(Rows.Count, 1).End(xlUp).Row
lr2 = sheet2.Cells(Rows.Count, 1).End(xlUp).Row
lr3 = sheet3.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr1
DoEvents
    check = sheet1.Cells(i, 1).Value
    lr3 = lr3 + 1
    For k = 1 To 5
        sheet3.Cells(lr3, k).Value = sheet1.Cells(lr3, k).Value
    Next k
    For j = 1 To lr2
        If sheet2.Cells(j, 4).Value = check And sheet2.Cells(j, 5).Value = vbNullString Then
            sheet2.Cells(j, 9).Value = "x"
            lr3 = lr3 + 1
            For k = 1 To 3
               sheet3.Cells(lr3, k + 5).Value = sheet2.Cells(lr3, k).Value
            Next k
            Exit For
        End If
    Next j
    lr3 = lr3 + 1
Next i
Application.Calculation = xlCalculationAutomatic
End Sub


It goes like: For each line on sheet1, copy the information I need to sheet3, then check all lines on sheet2 and see if it is from the same thing (Column 1 on sheet1 and Column 4 in sheet2). If it matches and it wasnt used yet, mark as used and put the info on sheet3 too, offset to the right.

Most of the variables are placeholders. Lr means lastrow, and the for loops uses i, j and k

I just have a problem that it is too slow, because both Sheet1 and Sheet2 can have around 100k lines, making it check 100k*100k times, to a total of 10kkk. I know the DoEvents makes it even slower, but I need a way to unlock excel, so it doesn't get that "Not responding" state for too long.

The output may look kinda weird, but it's how I need it for other places that I can't touch yet.
Shouldn't this:

For k = 1 To 5
    sheet3.Cells(lr3, k).Value = sheet1.Cells(lr3, k).Value
Next k


be this (you're not copying from row i on Sheet1) ?

For k = 1 To 5
    sheet3.Cells(lr3, k).Value = sheet1.Cells(i, k).Value
Next k


Would be faster as:

sheet3.Cells(lr3, 1).Resize(1, 5).Value = sheet1.Cells(i, 1).Resize(1, 5).Value


EDIT: this should be faster overall. Removes the nested loop and instead uses a dictionary to create a lookup on the sheet2 values.

Sub checkdata()

    Application.Calculation = xlCalculationManual
    Dim sheet1 As Worksheet, sheet2 As Worksheet, sheet3 As Worksheet
    Dim dict As Object, v

    Set sheet1 = Sheets(1)
    Set sheet2 = Sheets(2)
    Set sheet3 = Sheets(3)

    lr1 = sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    lr2 = sheet2.Cells(Rows.Count, 1).End(xlUp).Row
    lr3 = sheet3.Cells(Rows.Count, 1).End(xlUp).Row

    'Map all values+rows in Sheet2 ColD
    Set dict = CreateObject("scripting.dictionary")
    For j = 1 To lr2
        If sheet2.Cells(j, 5).Value = vbNullString Then
            v = jsheet2.Cells(j, 4).Value
            If Not dict.Exists(v) Then dict.Add v, j '&lt;&lt; capture value (first instance only) and row
        End If
    Next

    For i = 1 To lr1

        check = sheet1.Cells(i, 1).Value
        lr3 = lr3 + 1
        sheet3.Cells(lr3, 1).Resize(1, 5).Value = _
                sheet1.Cells(i, 1).Resize(1, 5).Value

        'does check exist on Sheet2 (with empty ColE value)?
        If dict.Exists(check) Then

            sheet2.Cells(dict(check), 9).Value = "x" '&lt;&lt;&lt; not Col 5 ?
            lr3 = lr3 + 1 '&lt;&lt;&lt; needed?
            sheet3.Cells(lr3, 6).Resize(1, 5).Value = _
                    sheet2.Cells(dict(check), 1).Resize(1, 5).Value
            Exit For
        End If

        lr3 = lr3 + 1 '&lt;&lt;&lt; needed?
    Next i

    Application.Calculation = xlCalculationAutomatic

End Sub