Having trouble copying adjacent cells when FindNext match is found - excel

Question

In Column A of Sheet 1, I have a list of serial numbers which contain duplicates. I want to delete all duplicates and instead come up with a history column which captures all the information of the adjacent cells with regards to that serial number. The logic of my script goes like this: 1) Filter all distinct serial numbers into a new sheet 2) For each cell in new sheet, find all matching cells in sheet 1 3) If they match then copy adjacent columns information and create an new column with new matching information 4) The more serial duplicates are, the bigger the "history" cell of that serial number is going to have
Here is a screenshot of what I'm trying to do:
https://imgur.com/a/KEn0RIP
When I use "FindPN.Interior.ColorIndex = 3", the program does fine, finding all the 1's in the column and coloring them red. I just want to copy each the 3 cells' values that are adjacent to each '1' in Column A. I have used a Dictionary to create a dynamic variable to spit out the final cell that I want, but when I run the program, I am having problems understanding how the place the variables in the FindNext loop to spit out each different B2, C2, and D2.
Sub FindPN1() 'simplified script finding all the 1's in Sheet 1
Dim I, J, K, L, Atotal As Integer
Dim FindPN, FoundPN As Range
Dim UniqueValue As Range
Dim strStatus, strDate, strComments As Object
Atotal = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
With Sheets(1)
For I = 2 To Atotal
Set FindPN = Sheets(1).Columns(1).Find(1, LookIn:=xlValues)
If Not FindPN Is Nothing Then
Set FoundPN = FindPN
Set strStatus = CreateObject("Scripting.Dictionary")
For J = 1 To Atotal
strStatus(J) = Range("B" & I).Value
Next
Set strComments = CreateObject("Scripting.Dictionary")
For K = 1 To Atotal
strComments(K) = Range("C" & I).Value
Next
Set strDate = CreateObject("Scripting.Dictionary")
For L = 1 To Atotal
strDate(L) = Range("D" & I).Value
Next
Range("A15").Value = strDate(1)
'FindPN.Interior.ColorIndex = 3
Do
Set FindPN = .Columns(1).FindNext(After:=FindPN)
If Not FindPN Is Nothing Then
strStatus(J) = Range("B" & I).Value
strComments(K) = Range("C" & I).Value
strDate(L) = Range("D" & I).Value
'FindPN.Interior.ColorIndex = 3
Range("B15").Value = strDate(3)
If FindPN.Address = FoundPN.Address Then Exit Do
Else
Exit Do
End If
Loop
End If
Next
End With
The problem I am having is not knowing how to store my variables and having them spit out the 'History' Cell the way that I want. I have been practicing by going inside the loop to see where each variable gets defined but it seems like the strDate is always spitting out the date corresponding to the first 1.

Answer 1

You can make this much simpler - use a single dictionary and loop over the rows.
Add new Id's (and their "history" value) where they don't exist: if an id is already in the dictionary then append the new piece of history to the existing value.
When done, loop over the dictionary and write out the keys and the values.
Sub CombineRows()
Dim i As Long, h, k, lastRow As Long
Dim dict As Object, wsSrc As Worksheet
Set wsSrc = Sheets(1)
lastRow = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
With Sheets(1).Rows(i)
k = .Cells(1).Value
h = .Cells(2).Value & "|" & _
.Cells(4).Text & "|" & _
.Cells(3).Value
If dict.exists(k) Then
dict(k) = dict(k) & vbLf & h
Else
dict.Add k, h
End If
End With
Next i
DumpDict dict, Sheets(2).Range("A1")
End Sub
'write out dictionary content starting at "rng"
Sub DumpDict(dict As Object, rng As Range)
Dim c As Range, k
Set c = rng.Cells(1)
For Each k In dict.keys
c.Value = k
c.Offset(0, 1).Value = dict(k)
Set c = c.Offset(1, 0)
Next k
End Sub