Solution for Excel VBA help – counting duplicates and filling in data based on those duplicates
is Given Below:
I’m hoping someone can help me with this. I’m working on a personal music project and using excel to organize my information. If this is too much for here, I’m happy to pay someone to write it for me. Send me an email to this username at gmail and let me know what your rate would be.
Here is what I am trying to do:
Sheet 1 has a lot of data in column A.
Each cell in column A needs to be cross referenced as a duplicate against a huge list of data in Sheet 2 Column B.
If no duplicates are found, put an “X” one cell to the right of the original cell (in Sheet1 Column B)
Now if duplicates are found, there may be between one and five of them
If there is a duplicate in column B sheet2, concatenate the contents of columns C and D from that same row in sheet2, and put that resulting string one cell to the right of the original cell (same place the X would go). If there are multiple duplicates, do the same thing, and put the result one more cell to the right in that same row. Repeat for all duplicates.
Really hoping somebody can help with this. Like I said, email me with your rate and I’m happy to pay for this.
Please, try the next code:
Sub processMusicData() 'It needs adding a reference to 'Microsoft Scripting Runtime' Dim sh As Worksheet, sh1 As Worksheet, lastRA As Long, lastRB As Long, dict As New Scripting.Dictionary Dim arrA, arrBD, arrDict, i As Long, j As Long, boolFound As Boolean Set sh = Worksheets("Sheet1") 'use here your sheet having data column A:A Set sh1 = Worksheets("Sheet2") 'use here your sheet having data columns B:D lastRA = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row in column A:A Sh lastRB = sh1.Range("B" & sh1.rows.count).End(xlUp).row 'last row in column B:B Sh1 arrA = sh.Range("A2:A" & lastRA).value 'place the range in an array to make code faster arrBD = sh1.Range("B2:D" & lastRB).value For i = 1 To UBound(arrA) 'iterate between arrA elements: For j = 1 To UBound(arrBD) 'iterate between arrBD elemets to match arrA element: If arrA(i, 1) = arrBD(j, 1) Then 'if a match is found: If Not dict.Exists(arrA(i, 1)) Then 'if not such a key in the dictionary: dict.Add arrA(i, 1), arrBD(j, 2) & arrBD(j, 3) 'create a key and its item by required concatenation Else 'if not in dictionary: dict(arrA(i, 1)) = dict(arrA(i, 1)) & "|" & arrBD(j, 2) & arrBD(j, 3) 'add the new concatenation separated by "|" End If boolFound = True 'make the variable True if a match has been found End If Next j If Not boolFound Then dict(arrA(i, 1)) = "X" 'if no match, create the key and its item as "X" boolFound = False 'reintitialize the boolean variable Next i For i = 1 To UBound(arrA) 'iterate between arrA elements arrDict = Split(dict(arrA(i, 1)), "|")'split the dictionary item of arrA(i,1) key sh.Range("B" & i + 1).Resize(1, UBound(arrDict) + 1).value = arrDict 'drop the above array content in the adiacent columns Next i End Sub
If you do not know how to add the necessary reference, please firstly run the next code. It will automatically add the reference:
Sub addScrRunTimeRef() 'Add a reference to 'Microsoft Scripting Runtime': 'In case of error ('Programmatic access to Visual Basic Project not trusted'): 'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings-> ' check "Trust access to the VBA project object model" Application.VBE.ActiveVBProject.References.AddFromFile "C:WindowsSysWOW64scrrun.dll" End Sub
Run the first code only after adding the reference.
Free of charge, even if you did not prove some personal interest in solving the problem by your own. I made an exception, breaking somehow the community rules. Please, at least, learn How to ask if will ever post a new question.