Explode two lists with all values of the other

From time to time, and I must admit, it doesn’t happen often, but often enough to justify making a macro, you will want to match two lists, e.g. a list of employees and a list of G/L accounts, and get as a result a line for each possible combination of employees and accounts.

Image

Here’s the excel version.

1. Copy the code listed at the end of this post in a standard VB module

2. Select both ranges: you select the employee list with the mouse, then press Ctrl, release the mouse button (while still holding the Ctrl key down) and select the GL list.

3. Run the macro: you now have a new tab with the expanded list ready for consumption.

Try it, you might like it.

Thomas

Here’s the code:

Sub ExplodeLists()
Dim rg1 As range, rg2 As range, shtDest As Worksheet, rgCell As range
Dim lLoop As Long, lRowDest As Long

‘turn off updates to speed up code execution
With application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

If selection.Areas.Count <> 2 Then
MsgBox “Select two areas to join”
Exit Sub
End If

Set rg1 = selection.Areas(1)
Set rg2 = selection.Areas(2)
Set shtDest = Worksheets.Add

lRowDest = 1

For lLoop = 1 To rg1.Rows.Count
shtDest.Cells(lRowDest, 1).Resize(rg2.Rows.Count, rg1.Columns.Count).Value = rg1.Rows(lLoop).Value
rg2.Copy shtDest.Cells(lRowDest, 1 + rg1.Columns.Count)
lRowDest = lRowDest + rg2.Rows.Count
Next

With application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

End Sub

Advertisements

3 comments on “Explode two lists with all values of the other

  1. Sorry, this is not an OUTER JOIN, this is a cartesian expansion.
    Still interesting and nice to have if you needed it, but not an OUTER JOIN.

    • Peter, you are fully correct. I just didn’t seem to find the right way of putting it, so used the wrong way of putting it that made the most sense to me.

      I’ve updated the title accordingly.

      Thanks

      • The real OUTER JOIN simulation is the following code, that expands both list so empty cells are inserted when one of the values is not matched:

        Sub Matchrows_OUTERJOIN_Sim()
        ‘Matches two ranges by inserting lines in both ranges so each value is on the same line

        ‘you first need to
        ‘ sort the two data blocks on the first column
        ‘ select the two data blocks you want to split and match

        Dim rg1 As range, rg2 As range, firstMatch As Boolean
        Dim i As Long, j As Long, foundRow As Long

        application.ScreenUpdating = False

        If selection.Areas.Count 2 Then
        MsgBox “Select two areas”
        Exit Sub
        End If

        Set rg1 = selection.Areas(1)
        Set rg2 = selection.Areas(2)

        ‘gets the number of unique values in the first rows of range 1 and 2, to be able to run the loop all the way
        Dim cUnique As New Collection

        On Error Resume Next

        With rg1
        For i = 1 To .Columns(1).Cells.Count
        cUnique.Add .Cells(i, 1), CStr(.Cells(i, 1))
        Next
        End With

        With rg2
        For i = 1 To .Columns(1).Cells.Count
        cUnique.Add .Cells(i, 1), CStr(.Cells(i, 1))
        Next
        End With

        On Error GoTo 0

        ‘boolean needed to be able to resize range 2 if required
        firstMatch = True

        For i = 1 To cUnique.Count
        If WorksheetFunction.CountA(rg1.Rows(i)) = 0 _
        Or WorksheetFunction.CountA(rg2.Rows(i)) = 0 _
        Or rg1.Cells(i, 1).Offset(0, rg2.Column – rg1.Column) = rg1.Cells(i, 1) Then
        firstMatch = False
        GoTo nxt_i:
        End If

        On Error Resume Next
        foundRow = rg2.Columns(1).Find(What:=rg1.Cells(i, 1), LookIn:= _
        xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False).Row

        If Err 0 Then
        Err.Clear
        rg1.Cells(i, 1).Offset(0, rg2.Column – rg1.Column).Resize(, rg2.Columns.Count).Insert Shift:=xlDown
        If firstMatch Then Set rg2 = rg2.Offset(-1).Resize(rg2.Rows.Count + 1)
        Else
        If i < foundRow Then
        rg1.Offset(i – 1).Cut Cells(foundRow, rg1.Column)
        Else
        rg2.Rows(foundRow – rg2.Row + 1).Cut
        rg2.Rows(i).Insert Shift:=xlDown
        End If

        firstMatch = False
        End If

        nxt_i:

        Next

        application.ScreenUpdating = True
        End Sub

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s