Load table into array and combine all duplicates- Excel VBA - arrays

Question

I have many tables that need data combined. I have combined some of the tables into a test table to test the code. I am sorting the unique values in column 'B' a-z before running my code. It is very slow with only ~3500 records. The actual total is over 100,000 records. I'm curious to see if I can load the whole table to an array and perform the same functions, but I'm not sure if it is possible.
My table structure is:
Unique ID
First
Last
Company
etc.
A1
John
A1
Doe
A1
company1
A2
Jay
Varnado
A3
Joe
Snuffy
A3
M.
company2
The desired outcome is:
Unique ID
First
Last
Company
etc.
A1
John
Doe
company1
A1
John
Doe
company1
A1
John
Doe
company1
A2
Jay
Varnado
A3
Joe M.
Snuffy
company2
A3
Joe M.
Snuffy
company2
Dim cel As Range, rng As Range, r As Range
Dim arr(14) As String, temp As String
Dim i As Long, b As Long, j As Long, lRow As Long, lRec As Long, c As Long
Dim ii As Integer, v As Integer, col As Integer
Dim dict As Scripting.Dictionary
Dim str() As String
Dim BenchMark As Double
BenchMark = Timer
lRow = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row
For c = 3 To lRow
Debug.Print c
Set cel = Sheet3.Range("B" & c)
If Trim(cel.Offset(1, 0)) = Trim(cel.Value) Then
'Determine range of like keys
i = 1
Do Until cel.Offset(i, 0).Value <> cel.Value
i = i + 1
Loop
lRec = cel.Offset(i, 0).Row - 1
'Compare data
For i = 3 To 16
ii = i - 3
'Create rng and loop through each column
Set rng = Sheet3.Range(Sheet3.Cells(c, i), Sheet3.Cells(lRec, i))
Set dict = New Scripting.Dictionary 'CreateObject("Scripting.Dictionary")
For Each r In rng
If dict.Exists(r.Value) = False And Len(r.Value) > 0 Then
dict.Add r.Value, r.Value
End If
Next r
'Add to string array
'Debug.Print Split(Join(dict.Keys, "|"), "|")
str = Split(Join(dict.Keys, ","), ",")
arr(ii) = Join(str, ",")
Set dict = Nothing
Next i
'Set range equal to array
For j = cel.Row To lRec
v = 0
For col = 3 To 16
Sheet3.Cells(j, col) = arr(v)
Sheet3.Cells(j, col) = arr(v)
v = v + 1
Next col
Next j
'Go to last cell in range
c = lRec
Else: GoTo NextCel
End If
'Clear array
NextCel:
On Error Resume Next
'Debug.Print Join(arr, ",")
Erase arr
On Error GoTo 0
Next c
MsgBox ("Done in " & Timer - BenchMark)
End Sub

Answer 1

Assuming ID is in column B and output as single lines per ID to Sheet1 or with duplicates to Sheet2.
Option Explicit
Sub Process()
Dim dict As Object, key
Dim iLastRow As Long, n As Long, r As Long
Dim c As Integer, s As String
Dim arIn, arOut, t0 As Single: t0 = Timer
Set dict = CreateObject("Scripting.Dictionary")
iLastRow = Sheet3.Cells(Rows.Count, "B").End(xlUp).Row
arIn = Sheet3.Range("A1").Resize(iLastRow, 16).Value2
n = 0
' determine number of unique ids
For r = 3 To iLastRow
key = Trim(arIn(r, 2))
If Len(key) > 0 Then
If Not dict.exists(key) Then
n = n + 1
dict.Add key, n
End If
End If
Next
' dimension output array and fill
ReDim arOut(1 To n, 1 To 15)
For r = 3 To iLastRow
key = Trim(arIn(r, 2))
n = dict(key)
arOut(n, 1) = key
' concat columns
For c = 3 To 16
s = Trim(arIn(r, c))
If Len(s) > 0 Then
arOut(n, c - 1) = arOut(n, c - 1) & " " & s
End If
Next
Next
' output to sheet1
Sheet1.Range("A1").Resize(n, 15) = arOut
MsgBox "Done in " & Format(Timer - t0, "0.0 secs")
' or with duplicates to sheet2
For r = 3 To iLastRow
key = Trim(arIn(r, 2))
n = dict(key)
Sheet2.Cells(r, 2) = key
For c = 3 To 16
Sheet2.Cells(r, c) = arOut(n, c - 1)
Next
Next
End Sub

Answer 2

This assumes the data is on Sheet1 starting in A1.
Not sure how efficient it is.
Option Explicit
Sub Test()
Dim rngDst As Range
Dim dicIDs As Object
Dim dicData As Object
Dim arrData As Variant
Dim arrCols As Variant
Dim idxRow As Long
Dim idxCol As Long
Dim ky As Variant
Dim fld As Variant
Dim cnt As Long
With Sheets("Sheet1").Range("A1").CurrentRegion
arrCols = .Rows(1).Value
arrData = .Offset(1).Resize(.Rows.Count - 1).Value
End With
Set dicIDs = CreateObject("Scripting.Dictionary")
For idxRow = LBound(arrData, 1) To UBound(arrData, 1)
ky = arrData(idxRow, 1)
If dicIDs.exists(ky) Then
Set dicData = dicIDs(ky)
cnt = cnt + 1
Else
Set dicData = CreateBlankDic(arrCols)
End If
For idxCol = LBound(arrData, 2) To UBound(arrData, 2)
fld = arrCols(1, idxCol)
If arrData(idxRow, idxCol) <> "" Then
dicData(fld) = arrData(idxRow, idxCol)
End If
Next idxCol
Set dicIDs(ky) = dicData
Next idxRow
Set rngDst = Sheets("Sheet1").Range("A1").Offset(, UBound(arrCols, 2) + 2)
rngDst.Resize(1, UBound(arrCols, 2)).Value = arrCols
Set rngDst = rngDst.Offset(1).Resize(cnt, UBound(arrCols, 2))
ReDim arrData(1 To cnt, 1 To UBound(arrCols, 2))
cnt = 1
For Each ky In dicIDs.keys
Set dicData = dicIDs(ky)
idxCol = 1
For Each fld In dicData.keys
arrData(cnt, idxCol) = dicData(fld)
idxCol = idxCol + 1
Next fld
cnt = cnt + 1
Next ky
rngDst.Value = arrData
End Sub
Function CreateBlankDic(arrKeys, Optional BlankVal = "") As Object
Dim dic As Object
Dim idxCol As Long
Set dic = CreateObject("Scripting.Dictionary")
For idxCol = LBound(arrKeys, 2) To UBound(arrKeys, 2)
dic(arrKeys(1, idxCol)) = BlankVal
Next idxCol
Set CreateBlankDic = dic
End Function