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

 

Posted by Blue Pecan Computer Training