用给定的两列列表创建一个具有所有潜在组合的表格（excel）

Question

是否有一种方法（vba代码或excel技巧）来操纵2个列式列表，以便我可以根据第一列中的唯一标识符获得具有所有可能组合的表？

例如我的一列包含“公司名称”，另一列包含“国家/地区位置”。如果每个公司的国家/地区组合在一起，我需要的是每一套（请参阅所附屏幕截图）。

Answer 1

此vba模块应该可以解决您的问题。只需将代码复制到新模块，声明输入和输出列以及列表第一行的编号。请注意，该代码将在到达“唯一标识符”单元格为空的行时停止。另外，它要求您的列表根据“唯一标识符”进行排序。如果唯一标识符仅出现一次，它将仍然被写入输出列表，但是只有一次，并且outColNation2在该行中保持空白。如果不希望这样做，应将其完全删除，只需删除注释的if语句。

Example Image of output

还要注意，唯一标识符最多可以重复100次。我认为它们似乎没有一个经常出现，因为那样会创建一个非常长的输出列表。

Option Compare Text

Sub COMBINATIONS()

Dim i As Long, j As Long, k As Long, l As Long, n As Long
Dim arr(100) As String
Dim UI As String

Dim inColUI As Integer, inColNation As Integer
Dim outColUI As Integer, outColNation1 As Integer, outColNation2 As Integer
Dim FirstRowOfData As Integer
Dim YourWS As Worksheet

inColUI = 1  'Column of the "Unique Identifier"
inColNation = 2 'Column of the "Nations" in your example

outColUI = 4
outColNation1 = 5   'output columns
outColNation2 = 6

FirstRowOfData = 2  'First Row of data

Set YourWS = Application.Worksheets("Sheet1") 'Put in your Worksheet Name here.

i = FirstRowOfData
n = FirstRowOfData
With YourWS
    Do Until .Cells(i, inColUI) = ""
        j = 0
        UI = .Cells(i, inColUI)
        Do Until .Cells(i - 1, inColUI) <> .Cells(i, inColUI) And j > 0 Or .Cells(i, inColUI) = ""
            arr(j + 1) = .Cells(i, inColNation)
            i = i + 1
            j = j + 1
        Loop
        If j = 1 Then '<- remove this if-statement and the following marked lines if single appearing UIs should be omitted entirely
            .Cells(n, outColUI) = UI '<---
            .Cells(n, outColNation1) = arr(1) '<---
            n = n + 1 '<---
        Else '<---
            For k = 1 To j
                For l = 1 To j
                    If arr(k) <> arr(l) Then
                        .Cells(n, outColUI) = UI
                        .Cells(n, outColNation1) = arr(k)
                        .Cells(n, outColNation2) = arr(l)
                        n = n + 1
                    End If
                Next l
            Next k
        End If '<---
    Loop
End With

End Sub

编辑：稍微整理一下代码

Answer 2

如下所示显示了如何遍历2个单元格范围

Dim Rng1 as Range, Rng2 as Range
Dim SrcCell as Range, OthrCell as Range
Dim FullList as string

Rng1 = Range("A1:A12")
Rng2 = Range("B1:B12")

FullList = ""
For Each SrcCell in Rng1
   For Each OthrCell in Rng2
      FullList = IIF(FullList="","",FullList & vbCrLf) & SrcCell.Value & OthrCell.Value
   Next OthrCell
Next srcCell

FullList字符串现在包含所有组合，但您可能需要其他组合。只打算给你一个开始

您需要自己添加代码以过滤出重复项

Answer 3

您可以执行以下操作（请参见下面的代码）。正如另一位评论者所述，当只有公司与国家/地区的记录时，将不会在输出中显示。

解决方案基于创建字典，每个条目都是公司，值是逗号分隔的国家/地区字符串。创建字典后，将字典循环，然后在嵌套循环中迭代国家/地区列表。如果外部循环的索引与循环的内部索引相同，则跳过该循环，即国家1与国家1的组合。否则将添加到输出列表。

[A，B列是输入，D，E，F列是输出。

Option Explicit

Public Sub sCombine()

  Dim r As Range, dest As Range
  Dim d As New Dictionary
  Dim key As Variant
  Dim countries() As String
  Dim i As Integer, j As Integer

  On Error GoTo error_next

  Set r = Sheet1.Range("A1")
  Set dest = Sheet1.Range("D:F")
  dest.ClearContents
  Set dest = Sheet1.Range("D1")

  While r.Value <> ""
    If d.Exists(r.Value) Then
      d(r.Value) = d(r.Value) & "," & r.Offset(0, 1)
    Else
      d.Add r.Value, r.Offset(0, 1).Value
    End If

    Set r = r.Offset(1, 0)
  Wend

  For Each key In d.Keys
    countries = Split(d(key), ",")
    For i = LBound(countries) To UBound(countries)
      For j = LBound(countries) To UBound(countries)
        If i <> j Then
          dest.Value = key
          dest.Offset(0, 1).Value = countries(i)
          dest.Offset(0, 2).Value = countries(j)
          Set dest = dest.Offset(1, 0)
        End If
      Next j
    Next i
  Next key

  Exit Sub
error_next:
  MsgBox Err.Description

End Sub