VBA to Create a new worksheet for each unique item

[raphagcwill]

I have this brillant macro which i got from (Excel VBA: New Worksheet For Each Unique Item in List & Copy Record –)

Basically it hat creates a new worksheet for each unique item that it finds in a list and then copies that record to the new sheet.

The problem i am facing is that i get an error whenever the sheet name already exists.

Can anybody help me to understand what is wrong?

The macro stops running at "NewWSheet.Name = BranchName 'named after that branch" whenever a sheet name already exists

Thanks in advance

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

 

[Fluff]

If the sheet name already exists then the code should never get to that line.
It sounds more as though BranchName is either blank or is not a valid sheet name.
What error message & number do you get?

 

[raphagcwill]

Hello!

I get the attached error.

The macro manages to creates new sheets for the values in D2, but stopps working as soon as a value repeats itself in column D

 

[Fluff]

Is the code in the same workbook, that you are adding the sheets to?

 

[raphagcwill]

The code is in my PERSONAL.XLSB!

 

[Fluff]

In that case change ThisWorkbook to ActiveWorkbook everywhere in the code.

 

[raphagcwill]

Ow....that worked like a charm.

thank you very much for taking the time to help me out. Much appreciated.

Have a nice day!
Cheers!

 

[Fluff]

You're welcome & thanks for the feedback.