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

[Beatrix]

Hi All,

I have a complex string data which I have to count number of function names by checking the LookUp list and copy/paste information into the sample worksheet column level including count of function names.

For each function name the row level data need to be repeated in Sample worksheet. I attached sample file.

I was wondering if this could be achieved if so your help would be much appreciated.

Many Thanks
B.

[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

[Beatrix]

Thank you Paul_Hossler this works perfect for me Much appreciated!!

Just one question please is it possible to count how many times a function name is used in String Data in Sample Worksheet. Clear and ClearCollect are two separate functions. For example Clear is used once and ClearCollect is used 12 times.

I assume In your script 'count number occurances' section should be achieving this but it didn't work for me

[Paul_Hossler]

Missed the number of times it's used. Add the <<<< line

Guessing what 'Clear' is supposed to do

Option Explicit


Sub Clear()
    With Worksheets("Sample")
        Range(.Range("D2"), .Range("D2").End(xlDown)).Resize(, 4).ClearContents
        Range(.Range("A3"), .Range("A3").End(xlDown)).Resize(, 2).ClearContents
    End With
End Sub




Sub ClearCollect()
    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
    
    Clear


    '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
                .Cells(iOut, 7).Value = aryCount(i)         '   <<<<<<<<<<< missed that
            End With
        
            iOut = iOut + 1
        
        End If
    Next i


    Application.ScreenUpdating = True


End Sub

[Beatrix]

Thank you very much Paul_Hossler . I tested it worked . I applied to my dataset by changing the parts in the sections below; however I noticed two things:

-My data set is a long list therefore it should insert a row for each matched function then copy/paste data to the new rows from the row number where string data belongs to and it should loop this for entire list. If there is no match then it shouldn't insert a row and should follow the same rule for next record - Is this possible ?

- Also there are some mismatched functions which miscalculates count of functions for Abs, Clear, Collect, Refresh, Sort, Update, Value. I made notes in Notes worksheet attached with sample data set.

I wonder if exact match is possible with look up list. Each function should only match if number of characters are the same and starts with capital letter ?

 sInput = Worksheets("Sample").Range("F2").Value

    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, 3).Value = Worksheets("Sample").Range("C2").Value
                .Cells(iOut, 4).Value = Worksheets("Sample").Range("D2").Value
                .Cells(iOut, 7).Value = rLookup.Cells(i, 1).Value
                .Cells(iOut, 8).Value = rLookup.Cells(i, 2).Value
                .Cells(iOut, 9).Value = rLookup.Cells(i, 3).Value
                .Cells(iOut, 10).Value = aryCount(i)         '   <<<<<<<<<<< missed that
            End With

[Paul_Hossler]

(1) -My data set is a long list therefore it should insert a row for each matched function then copy/paste data to the new rows from the row number where string data belongs to and it should loop this for entire list. If there is no match then it shouldn't insert a row and should follow the same rule for next record - Is this possible ?

(2) - Also there are some mismatched functions which miscalculates count of functions for Abs, Clear, Collect, Refresh, Sort, Update, Value. I made notes in Notes worksheet attached with sample data set.

(1) - not following what you mean

(2) - I used InStr and it matched substrings also, so CLEAR counted CLEAR, CLEARDATA, and CLEARCOLLECT. Messed up the numbers

Switched to a slightly more complicated algorithm so it seems more better

Option Explicit


Sub Clear()
    With Worksheets("Sample")
        Range(.Range("G2"), .Range("G2").End(xlDown)).Resize(, 4).ClearContents
        Range(.Range("A3"), .Range("A3").End(xlDown)).Resize(, 5).ClearContents
    End With
End Sub


Sub ClearCollect()
    Dim sInput As String, sTemp As String
    Dim aryKeys As Variant, aryWords As Variant
    Dim rLookup As Range
    Dim i As Long, j As Long, iOut As Long
    
    Application.ScreenUpdating = False
    
    Clear

    'init
    sInput = Worksheets("Sample").Range("F2").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))
    
    
    'remove non-alpha char from input string
    For i = 1 To Len(sInput)
        Select Case Mid(sInput, i, 1)
            Case "A" To "Z"
                sTemp = sTemp & Mid(sInput, i, 1)
            Case Else
                sTemp = sTemp & " "
        End Select
    Next i
    
    Do While InStr(sTemp, "  ") > 0
        sTemp = Replace(sTemp, "  ", " ")
    Loop
    
    aryWords = Split(sTemp, " ")
    
    'count number occurances
    For i = LBound(aryKeys) To UBound(aryKeys)
        aryKeys(i) = UCase(aryKeys(i))
        
        For j = LBound(aryWords) To UBound(aryWords)
            If aryWords(j) = aryKeys(i) Then aryCount(i) = aryCount(i) + 1
        Next j
    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, 3).Value = Worksheets("Sample").Range("C2").Value
                .Cells(iOut, 4).Value = Worksheets("Sample").Range("D2").Value
                .Cells(iOut, 7).Value = rLookup.Cells(i, 1).Value
                .Cells(iOut, 8).Value = rLookup.Cells(i, 2).Value
                .Cells(iOut, 9).Value = rLookup.Cells(i, 3).Value
                .Cells(iOut, 10).Value = aryCount(i)
            End With
        
            iOut = iOut + 1
        
        End If
    Next i

    Application.ScreenUpdating = True
    
    MsgBox "Done"

End Sub

[Beatrix]

This one worked better indeed many thanks Paul_Hossler

(2) - I used InStr and it matched substrings also, so CLEAR counted CLEAR, CLEARDATA, and CLEARCOLLECT. Messed up the numbers, Switched to a slightly more complicated algorithm so it seems more better

For the following below, I mean Is it possible to apply this logic for the entire range in column F ?

1) - not following what you mean

Just had a screenshot with sample.
F8, F10, F12 have matching functions from LookUp list.
F8 has only 1 matching function therefore the data in range A8 : D8 doesn't need copy/paste.

However; F10 has 2 matching functions therefore a row should be inserted and data between A10 : D10 need to repeat.
F12 has 3 matching functions, 2 rows should be inserted and data in range A12 : D12 need copy/paste.

Insert row action is needed if number of unique matching function for each cell in ColumnF>1
vbax sample.jpg

[Paul_Hossler]

Try this version

It's easier to just build a new output worksheet

Edit:

FUrther development:

You can format the Output WS or delete the Input and rename the Output

[p45cal]

I realise you asked for VBA which Paul has successfully provided, however, in the attached there's a Power Query solution.
In sheet Sample (2), your source data in a proper Excel table at cell A1
A Power Query table at cell I1.
If the data in the source table changes you can refresh the result table by right-clicking it and choosing Refresh (like you do with pivot tables.

I hope columns I to M appear as you want them to.
You'll see in this result table that column N (headed String) also repeats the string for every row in the results, which isn't too bad for this table, but if it were to be applied to to long text data as in cell F2 of the Sample sheet, it could become tiresome.

So on sheet Sample, in the Power Query results table at cell M1, I've used the same technique but removed the duplicates.
The source table for this is your data at cells D1:F2
Thankfully, this shows the same results as Paul's code which is in columns H to K. I hope columns M:N are as you want them.

If this is of interest, come back and I'll explain some more!

[Beatrix]

This is amazing Paul! Thank you for your time and support. Having this help is precious for me.
I need to spend sometime to understand each part in your code then I will apply to my original raw data.
Many thanks again!
B.

Try this version

It's easier to just build a new output worksheet

Edit:

FUrther development:

You can format the Output WS or delete the Input and rename the Output

[Beatrix]

Thank you for your time and help p45cal. I am always interested having different solutions, I didn't use Power Query before. My original data source has more than 5000 records and string data is quite complex ones usually like in cell F2 in Sample.

However I wonder how this solution works, where can I find the details of this Power Query please?

Many Thanks
B.

I realise you asked for VBA which Paul has successfully provided, however, in the attached there's a Power Query solution.
In sheet Sample (2), your source data in a proper Excel table at cell A1
A Power Query table at cell I1.
If the data in the source table changes you can refresh the result table by right-clicking it and choosing Refresh (like you do with pivot tables.

I hope columns I to M appear as you want them to.
You'll see in this result table that column N (headed String) also repeats the string for every row in the results, which isn't too bad for this table, but if it were to be applied to to long text data as in cell F2 of the Sample sheet, it could become tiresome.

So on sheet Sample, in the Power Query results table at cell M1, I've used the same technique but removed the duplicates.
The source table for this is your data at cells D1:F2
Thankfully, this shows the same results as Paul's code which is in columns H to K. I hope columns M:N are as you want them.

If this is of interest, come back and I'll explain some more!

[p45cal]

where can I find the details of this Power Query please?

There are loads of videos on the internet that you can search for.
Mynda Treacy is good: https://www.youtube.com/playlist?lis...dOH61MAiqlFHac
Leila Gharani too: https://www.youtube.com/playlist?lis...0q9TfYNN8bBjX-