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

The Match Columns macro – Absolutely useless until you need it.

You have two ranges with headers. Some of the headers match, some don’t. In addition, they’re not in the same order.

Select the first range, hold Ctrl before selection the second range and run the below code. All the columns of the second range are now matched to the columns of the first, and all unmatched columns of the second range are now at the end. Tada!

Try it, you might like it,
Thomas

Sub MatchColumns()
‘Matches two ranges by inserting columns in both ranges so each value is on the same column

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

Dim rg1 As range, rg2 As range
Dim firstMatch As Boolean
Dim i As Long, j As Long, foundCol 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 .Rows(1).Cells.Count
cUnique.Add .Cells(1, i), CStr(.Cells(1, i))
Next
End With

With rg2
For i = 1 To .Rows(1).Cells.Count
cUnique.Add .Cells(1, i), CStr(.Cells(1, i))
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 Len(rg1.Cells(1, i)) = 0 Or rg2.Cells(1, i) = rg1.Cells(1, i) Then
firstMatch = False
GoTo nxt_i:
End If

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

If Err 0 Then
Err.Clear
rg2.Offset(, i – 1).Resize(, 1).Insert Shift:=xlToRight
If firstMatch Then Set rg2 = rg2.Offset(, -1).Resize(, rg2.Columns.Count + 1)
Else
rg2.Columns(foundCol – rg2.Column + 1).Cut
rg2.Columns(i + rg2.Column – 1).Insert Shift:=xlToRight
firstMatch = False
End If

nxt_i:

Next

application.ScreenUpdating = True
End Sub