VBA-区分值并转置旁边数据的最佳方法？

Excel中的两列，列出候选人Id和首选城市（只是其中的一部分）：

如何使用VBA使它们看起来像下面这样：

 A         B         C          D         E          F
6957    Ankara     Antalya   İstanbul   İzmir
8469    İstanbul                
8470    İzmir      İstanbul             
8499    İstanbul        
8514    İstanbul                
7775    Ankara    Eskişehir  Kastamonu  Zonguldak   Karabük
8532    Ankara    Antalya    Bursa      İzmir

---

您可以尝试以下VBA宏-它在上述数据上对我有效：

Sub makeTable()
Dim inRange As Range
Dim outRange As Range
Dim currentCell, currentCandidate
Dim optionCount As Integer

Set inRange = Range("A2:A19")
Set outRange = Range("D2")

currentCandidate = inRange.Cells(1).Value
outRange.Value = currentCandidate
optionCount = 0

For Each currentCell In inRange.Cells
  If currentCell.Value = currentCandidate Then
    optionCount = optionCount + 1
  Else
    optionCount = 1
    Set outRange = outRange.Offset(1, 0)
    currentCandidate = currentCell.Value
    outRange.Value = currentCandidate
  End If
  outRange.Offset(0, optionCount) = currentCell.Offset(0, 1)

Next currentCell

End Sub

输出：

---

注意-这确实需要您对数据进行排序（先按候选人，然后按城市），但我认为您已经完成了排序。

这里还有一个建议。它将工作分为两个步骤：

将数据带到新结构中

将新结构写入Excel

有时，将工作环境分开是很有价值的。与Floris的代码片段不同，键列不必排序

（根据评论，算法于2014年6月25日20:30进行了编辑。）

备注:

无论何时由于无法检测到前方情况而必须使用VBA错误处理，您都有以下选项：

分支到错误处理程序并设置一些变量，这些变量将在主程序流中使用

在下一步恢复错误时使用

和
错误编号
和
错误清除

这两种选择都可能导致无法读取的代码，这取决于具体情况。在这里，选项1较短。此外，我不希望有“副作用”。主程序流中的变量由主程序流之外的错误处理程序奇妙地设置，提醒我注意副作用

---

在使用数组而不是集合时，可以将数组直接分配给范围，并在第2部分中保留内部循环

询问代码的问题必须证明对正在解决的问题的最低理解。包括尝试过的解决方案、它们不起作用的原因以及预期结果。另请参阅：请编辑您的帖子，并向我们展示您迄今为止所做的工作。非常感谢。为我工作well@Floris：与您的方法一样，它是密集和高效的：-）集合的良好使用-这当然是一种更灵活的方法，但它需要更多的资源。我想知道您是否可以进行最小的更改，这样就不需要对键进行排序：如果键存在，则添加元素；否则创建键和单个元素。哦，你说得对。我看到了。如果你使用字典之类的东西，你不需要触发键更改，也不需要对键进行排序。只需将所有值填充到匹配的键，如果还没有键，则使用空集合添加它。很高兴看到，thx:-）是的，这正是我的意思。你可能会考虑用另一种方法更新你的答案——这会产生非常好的代码，可以找到未来的用途…代码现在被改变了：

Sub makeTable()
Dim inRange As Range
Dim outRange As Range
Dim currentCell, currentCandidate
Dim optionCount As Integer

Set inRange = Range("A2:A19")
Set outRange = Range("D2")

currentCandidate = inRange.Cells(1).Value
outRange.Value = currentCandidate
optionCount = 0

For Each currentCell In inRange.Cells
  If currentCell.Value = currentCandidate Then
    optionCount = optionCount + 1
  Else
    optionCount = 1
    Set outRange = outRange.Offset(1, 0)
    currentCandidate = currentCell.Value
    outRange.Value = currentCandidate
  End If
  outRange.Offset(0, optionCount) = currentCell.Offset(0, 1)

Next currentCell

End Sub

Dim rIn As Range
Dim rOut As Range

Dim row As Range
Dim key
Dim value
Dim keyString As String

Dim resultCollection As Collection
Dim resultRow As Collection
Dim rowOffset As Integer
Dim columnOffset As Integer
Dim outItem

Set rIn = Range("A1:B9")
Set rOut = Range("C1")
Set resultCollection = New Collection

' 1. Loop through all rows of the input range.
For Each row In rIn.Rows

    key = row.Cells(1, 1)
    value = row.Cells(1, 2)

    keyString = CStr(key)

    ' VBA Collections cannot check if a key exists. Error checking is the way to go.
    ' Error 457 is to bear in mind: "This key is already associated with an element of this collection."
    On Error Resume Next 

    ' Try to add a new key and its collection.
    resultCollection.Add New Collection, keyString
    If Err.Number = 0 Then
        ' No error means that key has just been added. Init the entry.
        resultCollection(keyString).Add keyString
    End If
    ' Here, enhanced error handling is possible.
    Err.Clear
    On Error GoTo 0

    ' Here we are sure that the result collection was prepared with the right key and a collection.
    resultCollection(keyString).Add value

Next

' 2. Write the prepared resultCollectionto the sheet.
rowOffset = 0
For Each resultRow In resultCollection
    columnOffset = 0
    For Each outItem In resultRow
        rOut.Offset(rowOffset, columnOffset).value = outItem
        columnOffset = columnOffset + 1
    Next
    rowOffset = rowOffset + 1
Next