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.

    Click here to Enrol on the Ultimate Excel VBA Course
    30+ hrs - includes certification.

    All purchases help to support this blog - thanks!

    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