In this video I walk you through a VBA macro that combines associated records into a single record. The scenario is that we have a book club that records the reading activity of its members. Each read is recorded on a separate row: member’s name in column A and book title in column B.
Download the featured file here This file doesn’t contain the code as WordPress doesn’t like macro enabled Excel files, so you will need to copy the code below.
Option Explicit Sub TransposeBookData() Dim NameCol As Range Dim Name As Range Dim TrWS As Worksheet Dim FindName As String Sheets.Add(After:=Sheets("Book Club")).Name = "Transposed" 'Create the Transposed sheet Set TrWS = Worksheets("Transposed") With TrWS 'Create column headings in the Transposed sheet Range("A1") = "Name" Range("B1") = "Book 1" End With Worksheets("Book Club").Select Set NameCol = Range("A2", Range("A2").End(xlDown)) 'Set the Name column in the Book Club sheet as the column to loop through Worksheets("Transposed").Select For Each Name In NameCol 'Loop through each Name on the Book Club sheet If TrWS.Range("A2") = "" Then 'If Transpose sheet has no records Name.Resize(1, 2).Copy TrWS.Range("A2") 'Copy the first row into the transpose sheet Else If TrWS.Range("A:A").Find(Name) Is Nothing Then 'If the current Name is not found in the transpose sheet Name.Resize(1, 2).Copy TrWS.Range("A1").End(xlDown).Offset(1, 0) 'Copy the current row to the transpose sheet Else FindName = TrWS.Range("A:A").Find(Name).Address 'If the current Name is in the transpose sheet store its address Name.Offset(0, 1).Copy Destination:=TrWS.Range(FindName).End(xlToRight).Offset(0, 1) 'Copy and paste the Book title into the next available column in the transpose sheet End If End If Next Name Dim BookHdgs As Range Set BookHdgs = TrWS.Range(Cells(1, 2), Cells(1, TrWS.UsedRange.Columns.Count)) Range("B1").AutoFill Destination:=BookHdgs, Type:=xlFillSeries 'Create the book columns headings in the transpose sheet TrWS.UsedRange.Columns.AutoFit 'Autofit the columns in the transpose sheet TrWS.Range("A1").Select MsgBox "Transpose Complete" End Sub