Create a table with all potential combinations from a given list with two columns (excel)

Question

Is there a way (vba code or excel trick) to manipulate a 2 columnar list so that I get a table with all potential combinations depending on a unique identifier in the first column?

E.g. I have one column with Company Names and another with Country Locations. What I need is every set if combinations of the countries per company (see screenshot attached).

Answer 1

This vba module should solve your problem. Just copy the code to a new module, declare the input and output columns and the number of the first row of your list. Note that the code will stop once it hits a line where the "Unique Identifier" Cell is empty. Also, it requires that your list is sorted with respect to your "Unique Identifier". If a Unique Identifier only appears once, it will still be written into the output list, but only once and with the outColNation2 staying empty in that row. If this is not desired and it should be left out entirely, just delete the commented if-statement.

Example Image of output

Also note, that a unique identifier can repeat at most 100 times. I assume none of them appears that often as that would create a ridiculously long output list.

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

Edit: cleaned up the code a little bit

Answer 2

You can do the following (see code below). As another commentee mentioned, when there is only one record of company vs country, it will not show in the output.

The solutions is based on creating a dictionary, each entry is a company and the value is a comma separated string of countries. After the dictionary is created, the dictionary is looped, and a list of countries is then iterated over a nested loop. If the index of the outer loop is the same as the inner index of the loop then the loop is skipped i.e. that would be a Country 1 vs Country 1 combination. Otherwise is added to the output list.

Columns A,B is input and columns D,E,F is output.

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

Something like the following shows how to iterate through 2 ranges of cells

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

The FullList string now contains all the combinations but you may require something else. Only intended to give you a start

You need to add code yourself to filter out duplicates