This video tutorial features VBA code that creates a new worksheet for each unique item that it finds in a list and then copies that record to the new sheet.
In the featured scenario we have a thousand transaction records. The VBA code creates a new worksheet for each branch location that it finds in column D and then copies the record to that sheet. We end up with a sheet for each branch containing all the records for that branch.
Download the feature file here. (Includes the data but not the code. The code can be copied below).
Here’s the code featured in the video: please feel free to copy and paste it into your own project.
Here’s the code featured in the video, feel free to copy and paste it into your own project.
Sub CreateBranchSheets() Dim BranchField As Range Dim BranchName As Range Dim NewWSheet As Worksheet Dim WSheet As Worksheet Dim WSheetFound As Boolean Dim DataWSheet As Worksheet Set DataWSheet = Worksheets("Data") Set BranchField = DataWSheet.Range("D2", DataWSheet.Range("D2").End(xlDown)) Application.ScreenUpdating = False 'Loop through each branch name in column D For Each BranchName In BranchField 'Check whether the current branch name corresponds with an existing sheet name For Each WSheet In ThisWorkbook.Worksheets If WSheet.Name = BranchName Then WSheetFound = True Exit For ' if it does assign True to the WSheetFound variable and exit the For Each Next Loop Else WSheetFound = False ' if it doesn't assign False to the WSheetFound variable End If Next WSheet If WSheetFound Then 'if WSheetFound = True 'copy and paste the record to the relevant worksheet, in the next available row BranchName.Offset(0, -3).Resize(1, 13).Copy Destination:=Worksheets(BranchName.Value).Range("A1").End(xlDown).Offset(1, 0) Else 'if WSheetFound = False Set NewWSheet = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) ' insert a new Worksheet NewWSheet.Name = BranchName 'named after that branch DataWSheet.Range("A1", DataWSheet.Range("A1").End(xlToRight)).Copy Destination:=NewWSheet.Range("A1") 'and copy the headings to it BranchName.Offset(0, -3).Resize(1, 13).Copy Destination:=NewWSheet.Range("A2") ' then copy and paste the record to i End If Next BranchName 'autofit columns in each sheet in the workbook For Each WSheet In ThisWorkbook.Worksheets WSheet.UsedRange.Columns.AutoFit Next WSheet Application.ScreenUpdating = True End Sub