VBA Excel 2010：将值从字典插入新行

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