Создать таблицу со всеми возможными комбинациями из данного списка с двумя столбцами (Excel)

Question

Есть ли способ (код vba или трюк Excel) манипулировать списком из 2 столбцов, чтобы я мог получить таблицу со всеми возможными комбинациями в зависимости от уникального идентификатора в первом столбце?

Например, у меня есть одинстолбец с названиями компаний, а другой - с местами расположения стран. Что мне нужно, так это каждый набор, если комбинации стран на одну компанию (см. Скриншот прилагаются).

Answer 1

Этот модуль VBA должен решить вашу проблему. Просто скопируйте код в новый модуль, объявите столбцы ввода и вывода и номер первой строки вашего списка. Обратите внимание, что код остановится, как только попадет в строку, где ячейка «Уникальный идентификатор» пуста. Кроме того, он требует, чтобы ваш список был отсортирован по вашему «уникальному идентификатору». Если уникальный идентификатор появляется только один раз, он все равно будет записан в список вывода, но только один раз, а outColNation2 останется пустым в этой строке. Если это нежелательно и его следует полностью исключить, просто удалите закомментированный оператор if.

Пример изображения вывода

Также обратите внимание, что уникальный идентификаторможет повторить не более 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

Вы можете сделать следующее (см. Код ниже). Как упоминалось в другом комментарии, когда есть только одна запись о компании и стране, она не будет отображаться в выходных данных.

Решения основаны на создании словаря, каждая запись - это компания, а значение - запятая. разделенная строка стран. После того, как словарь создан, словарь зацикливается, и список стран затем повторяется по вложенному циклу. Если индекс внешнего цикла совпадает с внутренним индексом цикла, то цикл пропускается, т. Е. Это будет комбинация Страна 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

Answer 3

Пример примерно следующего показывает, как перебирать 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 теперь содержит все комбинации, но вам может потребоваться что-то еще. Только для того, чтобы дать вам старт

Вы должны добавить код самостоятельно, чтобы отфильтровать дубликаты