VBA to Create a new worksheet for each unique item

raphagcwill

New Member
Joined
Jan 12, 2016
Messages
41
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


VBA Code:
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
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
68,143
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Jan 12, 2016
Messages
41
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
 

Attachments

  • error.PNG
    error.PNG
    4.1 KB · Views: 6

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
68,143
Office Version
  1. 365
Platform
  1. Windows
Is the code in the same workbook, that you are adding the sheets to?
 

raphagcwill

New Member
Joined
Jan 12, 2016
Messages
41

ADVERTISEMENT

The code is in my PERSONAL.XLSB!
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
68,143
Office Version
  1. 365
Platform
  1. Windows
In that case change ThisWorkbook to ActiveWorkbook everywhere in the code.
 
Solution

raphagcwill

New Member
Joined
Jan 12, 2016
Messages
41
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
68,143
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,193
Messages
5,768,770
Members
425,492
Latest member
blueexcel123

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top