Skip to content
Home » Excel VBA: New Worksheet For Each Unique Item in List & Copy Record

Excel VBA: New Worksheet For Each Unique Item in List & Copy Record

    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.

    5 FREE EXCEL TEMPLATES
    Plus Get 30% off any Purchase in the Simple Sheets Catalogue!

    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