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

Question

我在使用某些VBA for Excel 2010时遇到了麻烦。我有一个名称列表，这些名称具有与之关联的不同序列号。 以下代码将查看A列中的名称，在名称字典中查找与此名称相关的序列号数组，并在新列中打印出每个数字。

名称字典：

Names("Jane B") = [111112, 22222]

输出：

|Joe A   | 11111
|Jane B  | 111112|  22222 |
|Jim C   | 11111 | 121212 | 1122112

码：

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

到现在为止还挺好。 但是输出格式不适用于输入Access。 相反，我想采用以下格式：

|Joe A   | 11111
|Jane B  | 111112
|Jane B  | 22222
|Jim C   | 11111
|Jim C   | 121212
|Jim C   | 1122112

这是我的代码：

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

这是我遇到问题的地方。 我的输出如下所示：

|Joe A   | 11111
|Joe A   | 1700
|Joe A   | 1700
|Joe A   | 1700
|Joe A   | 1700
|Joe A   | 1700
|Joe A   | 1700

虽然所有数字都组成了，但实际上输出的是1700，尽管这与任何序列号（???）都不相关。

谁能发现我代码中的错误？

谢谢大家的时间和考虑。

带着感激之情，

扎克

Answer 1

尝试以下操作：使用新的工作表（例如：“ NewContactSheet”）。 不必在当前的联系表中插入行，而是先插入一行，然后扫描下一行（刚插入的行），然后一次又一次地插入。

然后一次一次扫描联系表，并与您的字典完全一样。 然后，每个名称一次一个序列，您在新工作表上添加单元格1和2，并增加行。

没有字典可以测试，并且基于原始帖子说“到目前为止很好” ...

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