I am new to VBA, but want to try and make a code that groups, counts, sorts and vlookups values from 3 diferent files.
At the moment I am at a point where I group, sort and count the data, but the vlookup is not working properly - it gives answers that are not exact match, even dough its in the code.
Can you please help with here I am wrong?
Sub GroupMentionsSortedAndVLookupThreeWorkbooks()
Dim wsSource As Worksheet
Dim wsOutput As Worksheet
Dim mentionsRange As Range
Dim mentionDict As Object
Dim mention As Variant
Dim lastRow As Long
Dim i As Long
Dim outputRow As Long
Dim sortedMentions As Variant
Dim currentLetter As String
Dim firstLetter As String
Dim wb2 As Workbook
Dim ws2 As Worksheet
Dim lookupRange2 As Range
Dim lookupValue As String
Dim lookupResult2 As Variant
Dim wb3 As Workbook
Dim ws3 As Worksheet
Dim lookupRange3 As Range
Dim lookupResult3 As Variant
Dim wb4 As Workbook
Dim ws4 As Worksheet
Dim lookupRange4 As Range
Dim lookupResult4 As Variant
Dim combinedResult As String
Dim finalResult As String
' Set source and output worksheets in Workbook 1
Set wsSource = ThisWorkbook.Sheets("Sheet1") ' Source of the mentions
Set wsOutput = ThisWorkbook.Sheets("Sheet2") ' Output sheet for grouped mentions
' Clear the output sheet
wsOutput.Cells.Clear
' Find the last row with data in Sheet1 (Column A)
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
' Set the range for the mentions
Set mentionsRange = wsSource.Range("A1:A" & lastRow)
' Create a dictionary object to store mention counts
Set mentionDict = CreateObject("Scripting.Dictionary")
' Loop through the mentions and count occurrences
For i = 1 To mentionsRange.Rows.Count
mention = mentionsRange.Cells(i, 1).Value
If mentionDict.exists(mention) Then
mentionDict(mention) = mentionDict(mention) + 1
Else
mentionDict.Add mention, 1
End If
Next i
' Get the sorted list of keys (mentions)
sortedMentions = mentionDict.Keys
Call QuickSort(sortedMentions, LBound(sortedMentions), UBound(sortedMentions))
' Output the grouped mentions and counts to Sheet2
outputRow = 1
wsOutput.Cells(outputRow, 1).Value = "Item"
wsOutput.Cells(outputRow, 2).Value = "Count"
wsOutput.Cells(outputRow, 3).Value = "Lookup from WB2"
wsOutput.Cells(outputRow, 4).Value = "Lookup from WB3"
wsOutput.Cells(outputRow, 5).Value = "Lookup from WB4"
wsOutput.Cells(outputRow, 6).Value = "Final Combined Result"
outputRow = outputRow + 1
' Open Workbook2, Workbook3, and Workbook4
Set wb2 = Workbooks.Open("C:\path\to\Workbook2.xlsx") ' Update the path to Workbook2
Set ws2 = wb2.Sheets("Sheet1") ' Update if Workbook2 has a different sheet name
lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
Set lookupRange2 = ws2.Range("A1:B" & lastRow) ' Lookup range in Workbook2 (A and B)
Set wb3 = Workbooks.Open("C:\path\to\Workbook3.xlsx") ' Update the path to Workbook3
Set ws3 = wb3.Sheets("Sheet1") ' Update if Workbook3 has a different sheet name
lastRow = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row
Set lookupRange3 = ws3.Range("A1:B" & lastRow) ' Lookup range in Workbook3 (A and B)
Set wb4 = Workbooks.Open("C:\path\to\Workbook4.xlsx") ' Update the path to Workbook4
Set ws4 = wb4.Sheets("Sheet1") ' Update if Workbook4 has a different sheet name
lastRow = ws4.Cells(ws4.Rows.Count, "A").End(xlUp).Row
Set lookupRange4 = ws4.Range("A1:B" & lastRow) ' Lookup range in Workbook4 (A and B)
' Add alphabetic separators and output the sorted data
currentLetter = ""
For i = LBound(sortedMentions) To UBound(sortedMentions)
mention = sortedMentions(i)
firstLetter = UCase(Left(mention, 1))
' If the first letter of the mention has changed, add a separator row
If firstLetter <> currentLetter Then
wsOutput.Cells(outputRow, 1).Value = firstLetter
wsOutput.Cells(outputRow, 1).Font.Bold = True
wsOutput.Cells(outputRow, 1).Font.Size = 12
outputRow = outputRow + 1
currentLetter = firstLetter
End If
' Output the mention and its count
wsOutput.Cells(outputRow, 1).Value = mention
wsOutput.Cells(outputRow, 2).Value = mentionDict(mention)
' Perform the VLOOKUP for this mention in Workbook2
lookupValue = Trim(CStr(mention)) ' Convert to string and trim spaces
On Error Resume Next
lookupResult2 = Application.WorksheetFunction.VLookup(lookupValue, lookupRange2, 2, False)
On Error GoTo 0
If IsError(lookupResult2) Then
lookupResult2 = "#N/A"
End If
' Perform the VLOOKUP for this mention in Workbook3
On Error Resume Next
lookupResult3 = Application.WorksheetFunction.VLookup(lookupValue, lookupRange3, 2, False)
On Error GoTo 0
If IsError(lookupResult3) Then
lookupResult3 = "#N/A"
End If
' Perform the VLOOKUP for this mention in Workbook4
On Error Resume Next
lookupResult4 = Application.WorksheetFunction.VLookup(lookupValue, lookupRange4, 2, False)
On Error GoTo 0
If IsError(lookupResult4) Then
lookupResult4 = "#N/A"
End If
' Output the individual lookup results in Columns C, D, and E
wsOutput.Cells(outputRow, 3).Value = lookupResult2
wsOutput.Cells(outputRow, 4).Value = lookupResult3
wsOutput.Cells(outputRow, 5).Value = lookupResult4
' Combine the results
combinedResult = ""
If lookupResult2 <> "#N/A" Then combinedResult = lookupResult2
If lookupResult3 <> "#N/A" Then
If combinedResult <> "" And combinedResult <> lookupResult3 Then
combinedResult = combinedResult & " \ " & lookupResult3
ElseIf combinedResult = "" Then
combinedResult = lookupResult3
End If
End If
If lookupResult4 <> "#N/A" Then
If combinedResult <> "" And combinedResult <> lookupResult4 Then
combinedResult = combinedResult & " \ " & lookupResult4
ElseIf combinedResult = "" Then
combinedResult = lookupResult4
End If
End If
' If no matches, display #N/A
If combinedResult = "" Then
combinedResult = "#N/A"
End If
' Output the final combined result in Column E
wsOutput.Cells(outputRow, 6).Value = combinedResult
outputRow = outputRow + 1
Next i
' Close Workbook2, Workbook3, and Workbook4
wb2.Close False
wb3.Close False
wb4.Close False
MsgBox "Mentions have been grouped, sorted, and lookup results combined successfully!", vbInformation
End Sub
' QuickSort algorithm to sort the mentions alphabetically
Sub QuickSort(arr As Variant, low As Long, high As Long)
Dim pivot As Variant
Dim i As Long
Dim j As Long
Dim temp As Variant
If low < high Then
pivot = arr((low + high) \ 2)
i = low
j = high
Do While i <= j
Do While arr(i) < pivot
i = i + 1
Loop
Do While arr(j) > pivot
j = j - 1
Loop
If i <= j Then
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
i = i + 1
j = j - 1
End If
Loop
Call QuickSort(arr, low, j)
Call QuickSort(arr, i, high)
End If
End Sub
This will not work as you expect it to:
' Perform the VLOOKUP for this mention in Workbook2
lookupValue = Trim(CStr(mention)) ' Convert to string and trim spaces
On Error Resume Next
lookupResult2 = Application.WorksheetFunction.VLookup(lookupValue, lookupRange2, 2, False)
On Error GoTo 0
If IsError(lookupResult2) Then
lookupResult2 = "#N/A"
End If
When using WorksheetFunction if no match is made then that line raises an error and no assignment is made for lookupResult2, and it retains whatever value it had previously.
This would work:
lookupResult2 = Application.VLookup(lookupValue, lookupRange2, 2, False)
'then check using `If IsError(lookupResult2)`
Without the WorksheetFunction, vlookup returns an error value if there's no match.