It seems TRANSPOSE has some limits
I changed macro to not use TRANSPOSE
Added a FillGK macro to populate 7000 and 350,000 entries in G and K
macro Match_1 seems to work, but takes awhile
Option Explicit
Sub FillGK()
Dim G As Range, K As Range
Dim i As Long
Set G = Range("G1").CurrentRegion
Set K = Range("K1").CurrentRegion
Application.ScreenUpdating = False
For i = 1 To 7000 \ G.Rows.Count
Application.StatusBar = "G -- " & i
G.Copy Range("G1").End(xlDown).Offset(1, 0)
DoEvents
Next i
For i = 1 To 350000 \ K.Rows.Count
Application.StatusBar = "K -- " & i
K.Copy Range("k1").End(xlDown).Offset(1, 0)
DoEvents
Next i
Application.StatusBar = False
End Sub
Option Explicit
Sub match_1()
Dim rG As Range, rK As Range
Dim aG As Variant, aK As Variant, aN As Variant
Dim aG5() As Variant, aK5() As Variant
Dim G As Long, K As Long, g1 As Long, k1 As Long, n As Long
'setup G's
Set rG = ActiveSheet.Cells(1, 7)
Set rG = Range(rG, rG.End(xlDown))
rG.Interior.ColorIndex = xlColorIndexNone
aG = rG.Value
ReDim aG5(LBound(aG, 1) To UBound(aG, 1))
For G = LBound(aG, 1) To UBound(aG, 1)
If G Mod 100 = 0 Then
Application.StatusBar = "Spliting G = " & Format(G, "#,##0")
DoEvents
End If
aG5(G) = Split(aG(G, 1), "-")
Next G
'setup K's
Set rK = ActiveSheet.Cells(1, 11)
Set rK = Range(rK, rK.End(xlDown))
rK.Interior.ColorIndex = xlColorIndexNone
aK = rK.Value
ReDim aK5(LBound(aK, 1) To UBound(aK, 1))
For K = LBound(aK, 1) To UBound(aK, 1)
If K Mod 100 = 0 Then
Application.StatusBar = "Spliting K = " & Format(K, "#,##0")
DoEvents
End If
aK5(K) = Split(aK(K, 1), "-")
Next K
'check
For G = LBound(aG, 1) To UBound(aG, 1)
For K = LBound(aK, 1) To UBound(aK, 1)
If K Mod 100 = 0 Then
Application.StatusBar = "Checking G = " & Format(G, "#,##0") & " -- K = " & Format(K, "#,##0")
DoEvents
End If
If aG5(G)(4) < aK5(K)(0) Then GoTo NextK ' largest G < smallest K
If aG5(G)(0) > aK5(K)(4) Then GoTo NextK ' smallest G > largest K
n = 0
For g1 = 0 To 4
For k1 = 0 To 4
If k1 = 3 And n <= 2 Then Exit For ' not enougth left
If aG5(G)(g1) = aK5(K)(k1) Then
n = n + 1
If n >= 3 Then ' Found 3 so mark and get out
rG.Cells(G).Interior.Color = vbRed
rK.Cells(K).Interior.Color = vbRed
Exit For
End If
End If
Next k1
Next g1
NextK:
Next K
NextG:
Next G
End Sub