Excel Forum

Code: Select all

Sub test0()
    Dim arr(999, 2) As Variant
    Dim rsa As Range, rsb As Range
    Dim ra As Range, rb As Range
    Dim j As Integer, k As Integer
    With Worksheets("Sheet2")
        Set rsa = .Range("a1").CurrentRegion
    End With
    With Worksheets("Sheet1")
        Set rsb = .Range("a5").CurrentRegion.Offset(0, 1).Resize(, 1)
    End With
    j = 0
    For Each ra In rsa
        arr(j, 0) = ra.Value
        k = j
        For Each rb In rsb
            If VBA.InStr(rb.Value, ra.Value) Then
                arr(j, 1) = rb.Value
                arr(j, 2) = rb.Next.Value
                j = j + 1
            End If
        Next rb
        If j = k Then
            j = j + 1
        End If
    Next ra
    If j > 0 Then
        Worksheets("QTY").Range("a2").Resize(j, 3).Value = arr
    End If
End Sub

Code: Select all

'Other code
With Worksheets("Sheet1")
    Set rsb = .Range("b5", .Range("b" & .Rows.Count).End(xlUp))
End With
'Other code