Copy/Paste/Count String Data from LookUp List with VBA

[Paul_Hossler]

Maybe something like this

Option Explicit




Sub Ver_1()
    Dim sInput As String
    Dim aryKeys As Variant
    Dim rLookup As Range
    Dim i As Long, iPos As Long, iOut As Long
    
    Application.ScreenUpdating = False
    
    'init
    sInput = Worksheets("Sample").Range("C2").Value
    sInput = UCase(sInput)
    Set rLookup = Worksheets("Lookup").Cells(1, 1).CurrentRegion
    aryKeys = Application.WorksheetFunction.Transpose(rLookup.Columns(1).Value)
    ReDim aryCount(LBound(aryKeys) To UBound(aryKeys))
    
    'count number occurances
    For i = LBound(aryKeys) To UBound(aryKeys)
        aryKeys(i) = UCase(aryKeys(i))
        
        iPos = 1
        iPos = InStr(iPos, sInput, aryKeys(i), vbBinaryCompare)
        
        Do While iPos > 0
            aryCount(i) = aryCount(i) + 1
            
            iPos = iPos + 1
            If iPos > Len(sInput) Then Exit Do
            
            iPos = InStr(iPos, sInput, aryKeys(i), vbBinaryCompare)
        Loop
    Next i
    
    'if num occurances > 0 then write to output sheet
    iOut = 2
    
    For i = LBound(aryCount) To UBound(aryCount)
        If aryCount(i) > 0 Then
            With Worksheets("Sample")
                .Cells(iOut, 1).Value = Worksheets("Sample").Range("A2").Value
                .Cells(iOut, 2).Value = Worksheets("Sample").Range("B2").Value
                .Cells(iOut, 4).Value = rLookup.Cells(i, 1).Value
                .Cells(iOut, 5).Value = rLookup.Cells(i, 2).Value
                .Cells(iOut, 6).Value = rLookup.Cells(i, 3).Value
            End With
        
            iOut = iOut + 1
        
        End If
    Next i


    Application.ScreenUpdating = True


End Sub