Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
This script combines data but writes the results to rows (with a new column for each item)
Option Explicit
Public Sub SplitCampersByCabin()
Dim lngLastRow As Long, lngIdx As Long, lngNextCol As Long, _
lngCabinRow As Long
Dim wksCampers As Worksheet, wksCabins As Worksheet
Dim varCamper As Variant, varCabin As Variant
Dim dicCampers As Scripting.Dictionary, _
dicCabins As Scripting.Dictionary
Dim strCamper As String, strCabin As String
Set dicCampers = New Dictionary
Set dicCabins = New Dictionary
'We start by identifying the starting sheet
Set wksCampers = ThisWorkbook.Worksheets("campers")
'Let's also create a new sheet, where we'll output the transposed data
ThisWorkbook.Worksheets.Add After:=wksCampers
Set wksCabins = ThisWorkbook.ActiveSheet
wksCabins.Name = "cabins"
'Now we'll identify the limits of our data and build our dictionaries
With wksCampers
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
'This builds the dicCamper dictionary, where names are keys,
'as well as the dicCabins dictionary, with cabins as keys
For lngIdx = 2 To lngLastRow
strCamper = .Cells(lngIdx, 1)
strCabin = .Cells(lngIdx, 2)
'If this camper is not already in the dictionary, add him or her!
If Not dicCampers.Exists(strCamper) Then
dicCampers.Add Key:=strCamper, Item:=strCabin
End If
'If this cabin is not already in the dictionary, add it!
If Not dicCabins.Exists(strCabin) Then
dicCabins.Add Key:=strCabin, Item:=strCabin
End If
Next lngIdx
End With
'Now we'll start outputting the transposed data to the cabins sheet
lngCabinRow = 1
With wksCabins
'First, our "outer" loop iterates through all the cabins
For Each varCabin In dicCabins.Keys
.Cells(lngCabinRow, 1) = dicCabins(varCabin)
lngNextCol = 2
'Then, our "inner" loop iterates through all the campers
For Each varCamper In dicCampers.Keys
'If this camper's cabin matches the current cabin,
'write the campers name into that row
If dicCampers(varCamper) = dicCabins(varCabin) Then
.Cells(lngCabinRow, lngNextCol) = varCamper
lngNextCol = lngNextCol + 1
End If
Next varCamper
lngCabinRow = lngCabinRow + 1
Next varCabin
End With
'Let the user know that the macro is finished
MsgBox "Script complete!"
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.