从给定列表中创建一个包含所有可能组合的表，其中包含两列（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