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 :joy: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 :think:

[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 :content:. 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:yes 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 ? :think:

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 : pray2:
31327

[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?list=PLmd91OWgLVSKnVrL0YxdOH61MAiqlFHac
Leila Gharani too: https://www.youtube.com/playlist?list=PLmHVyfmcRKyyKV86N7i0q9TfYNN8bBjX-