Need help gettin this macro to run faster, Please!

[Paul_Hossler]

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