EXCEL VBA: Mapping of data is too slow - excel

Question

I am running sub where it compares two cells (B and D/or string Received) from one sheet ("DATA") with two cells (C, H) from another sheet ("Incoming_report"), and if they match it transposes I, G cells from Incoming to Data.
It is done by combining two cells from Incoming_report sheet and writing new value in Z column for example "123456" from C and H to f.e. "123456Received" (there another 5 statuses (Received, Rejected, Sent...., but I need the ones only that was Received)
Then I am taking from Data Sheet B column for example 123456 and only Received (there might be another 5 statuses, but I only need the one that was received).
That makes all sence to me and works pretty good, but I have to work with more than 500k rows in each sheet. What happens - 500,000 times two cells are combined and searched in Z column in another sheet among another 500,000 for possible match, if nothing found then N/A, and then 2 combination, 3rd, 4th... till 500,000. I added the Display status bar and I see how slowly it goes (only 900 rows per minute, so for one minor mapping it would take more than 10 hours). Here is the sub itself, can anyone share ideas how to improve it to make it work faster? Thanks a million.
Sub incoming_fetch()
Application.ScreenUpdating = False
Dim incr As Long
Dim x As String
n = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Z = Sheets("Incoming_report").Range("D" & Rows.Count).End(xlUp).Row
For i2 = 2 To Z
Sheets("Incoming_report").Range("Z" & i2).Value = Sheets("Incoming_report").Range("C" & i2).Value & Sheets("Incoming_report").Range("H" & i2).Value
Next i2
For i = 3 To n
Application.DisplayStatusBar = True
Application.StatusBar = i
x = Sheets("Data").Range("B" & i).Value & "Received"
If Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas) Is Nothing Then
Sheets("Data").Range("L" & i) = "N/A"
Sheets("Data").Range("M" & i) = "N/A"
Else
incr = Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas).Row
Sheets("DATA").Range("L" & i) = Sheets("Incoming_report").Range("I" & incr)
Sheets("DATA").Range("M" & i) = Sheets("Incoming_report").Range("G" & incr)
End If
Next i
End Sub

Answer 1

EDIT2: fixed source columns :
Sub incoming_fetch()
Dim i As Long, n As Long, z As Long, num As Long
Dim x As String
Dim shtIn As Worksheet, shtData As Worksheet
Dim dict As Object, arrC, arrH, arrG, arrI, v, arr, r1, r2
Dim t
Set dict = CreateObject("scripting.dictionary")
Set shtIn = Sheets("Incoming_report")
Set shtData = Sheets("Data")
n = shtData.Range("A" & Rows.Count).End(xlUp).Row
z = shtIn.Range("D" & Rows.Count).End(xlUp).Row
t = Timer
'get all values from Cols C, H, L, M
arrC = shtIn.Range(shtIn.Range("C2"), shtIn.Range("C" & z)).Value
arrH = shtIn.Range(shtIn.Range("H2"), shtIn.Range("H" & z)).Value
arrG = shtIn.Range(shtIn.Range("G2"), shtIn.Range("G" & z)).Value
arrI = shtIn.Range(shtIn.Range("I2"), shtIn.Range("I" & z)).Value
Debug.Print "Get Arrays: " & Timer - t
t = Timer
'create a lookup dictionary of all the ColC values
' (where ColH = "Received")
num = UBound(arrC, 1)
For i = 1 To num
v = arrC(i, 1)
If arrH(i, 1) = "Received" And Len(v) > 0 Then
dict(v) = Array(arrI(i, 1), arrG(i, 1))
End If
Next i
'free up some memory
Erase arrC: Erase arrH: Erase arrI: Erase arrG
Debug.Print "Filled dict: " & Timer - t
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo haveError
For i = 3 To n
If i Mod 500 = 0 Then Application.StatusBar = i
x = shtData.Range("B" & i).Value
If dict.exists(x) Then
arr = dict(x)
r1 = arr(0)
r2 = arr(1)
Else
r1 = "N/A": r2 = "N/A"
End If
With shtData
.Range("L" & i) = r1
.Range("M" & i) = r2
End With
Next i
Debug.Print "Done: " & Timer - t
haveError:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub