VBA Excel 2010: Inserting values from dictionary into new row - vba

Question

I'm having trouble with some VBA for Excel 2010. I have a list of names that have different serial numbers associated with them. The following code will look at a name in column A, look it up in the names dictionary for an array of serial numbers associated with this name, and print out each number in a new column.
Names Dictionary:
Names("Jane B") = [111112, 22222]
Output:
|Joe A | 11111
|Jane B | 111112| 22222 |
|Jim C | 11111 | 121212 | 1122112
Code:
Dim name, counter
For i = 2 To Worksheets("Contacts").UsedRange.Rows.Count
name = Worksheets("Contact").Cells(i, 1)
counter = 0
If names.Exists(name) Then
For Each serial In names(name)
Worksheets("Contact").Cells(i, 2+counter).Value = serial
counter = counter + 1
Next serial
End If
Next i
So far, so good. But the output format isn't good for inputting into Access. Instead, I'd like to have the following format:
|Joe A | 11111
|Jane B | 111112
|Jane B | 22222
|Jim C | 11111
|Jim C | 121212
|Jim C | 1122112
Here's my code:
Dim name, counter
For i = 2 To Worksheets("Contact").UsedRange.Rows.Count
name= Worksheets("Contact").Cells(i, 1)
counter = 0
If names.Exists(name) Then
For Each serial In names(name)
Worksheets("Contact").Cells(i + counter, 2).Value = serial
Worksheets("Contact").Cells(i + counter, 1).Value = name
Worksheets("Contact").Cells(i + counter + 1, 1).EntireRow.Insert
counter = counter + 1
Next serial
End If
Next i
This is where I run into a problem. My output looks like this:
|Joe A | 11111
|Joe A | 1700
|Joe A | 1700
|Joe A | 1700
|Joe A | 1700
|Joe A | 1700
|Joe A | 1700
While the numbers are all made up, the 1700 output is actually what is outputting, although that doesn't relate to any serial number (???).
Can anyone spot what's off in my code?
Thank you all for your time and consideration.
With gratitude,
Zac

Answer 1

Try this: Use a new sheet (example: "NewContactSheet").
Instead of inserting rows to the current contact sheet, which makes you insert a row then scan the next row (the one you just inserted) and insert it again and again.
Then scan the contact sheet one row at a time, and compare to the dictionary exactly as you are. Then, one serial at a time per Name, you add cell 1 and 2 on the new sheet and increment the row.
Without the dictionary to test with, and based on the original post saying "So far so good"...
Sub SerialNameMover()
Dim name As String
Dim counter As Integer
Dim lastContactRow As Integer
Dim newSheet As String
Dim nRow As Integer
Dim i As Integer
newSheet = "NewContactSheet"
nRow = 2
lastContactRow = Worksheets("Contact").UsedRange.Rows.Count
For i = 2 To lastContactRow
name = Sheets("Contact").Cells(i, 1)
If Names.Exists(name) Then
For Each serial In Names(name)
Sheets(newSheet).Cells(nRow, 1) = name
Sheets(newSheet).Cells(nRow, 2) = serial
nRow = nRow + 1
Next serial
End If
Next i
End Sub