VBA Help!! Splitting out worksheets macro

[kenchristensen11]

I have a central tab called "Summaries". From this tab, I'd like to assign a macro to a button that separates out new worksheets based on titles starting in cell B5, with the name of the tabs matching the titles. Sometimes, the number of titles can vary but they will always begin in cell B5.

In each worksheet, I'll need to assign a standard template (let's call them "Domestic" and "Canadian" that are separate, hidden sheets in the workbook). Based on values beginning in cell F5 from the "Summaries" tab, I need the macro to either use the "Domestic" of "Canadian" template based on searching whether or not the keyword "Canada" is anywhere beginning in cell F5 from the "Summaries" tab. So, if there's "Canada" anywhere from cell F5 to the last row in the "Summaries" tab, use the "Canadian" template. If not, use the "Domestic".

Thanks for all the help in advance!!!

 

[sijpie]

Option Explicit

Sub MakeNewSheets()
    Dim wsN As Worksheet, wsThis As Worksheet, wsTempl As Worksheet
    Dim bDC As Boolean
    Dim rFind As Range, rN As Range
    Dim i As Integer
    Const sCan As String = "Canada"
    
    Set wsThis = ActiveSheet    'With all the new sheets we are making don't want to lose track of the original
    
    ' See if "Canada" is found in column F. I have used a intersect construction here to get the range to be searched
    Set rFind = Intersect(Columns("F"), Range("F5").CurrentRegion).Find(What:=sCan)
    If Not rFind Is Nothing Then bDC = True ' if rFind is not nothing, it means "Canada" has been found
    
    If bDC Then
        Set wsTempl = Sheets("Canadian")
    Else
        Set wsTempl = Sheets("Domestic")
    End If
    
    'Now start making the sheets
    Application.ScreenUpdating = False  ' hide all the screen activity
    
    wsTempl.Visible = xlSheetVisible    'unhide the template, else all new sheets will be hidden
        
    Set rN = wsThis.Range("B5")
    Do While Len(rN.Value)              'loop while rN is not empty
        wsTempl.Copy after:=Sheets(Sheets.Count)    'copy as last sheet
        Set wsN = ActiveSheet
        If CheckSht(ThisWorkbook, rN.Value) Then    'chek if sheet already exists
            wsN.Name = rN.Value & "-" & Format(Now(), "hhmmss") 'if so add time to name to make it unique
        Else
            wsN.Name = rN.Value             ' give it the name of the current cell in column B
        End If
        Set rN = rN.Offset(1, 0)        ' move rN one cell down
        i = i + 1
    Loop
    wsTempl.Visible = xlSheetHidden     'hide the template again
    wsThis.Activate                     'show the user the original sheet
    Application.ScreenUpdating = True
    
    MsgBox prompt:=i & " worksheets have been created based on template " & wsTempl.Name, _
           Title:="New sheets created"
           
    
End Sub

Function CheckSht(wbWB As Workbook, sName As String) As Boolean
' Check if sheet sName exists in workbook wbWB
'
    Dim wsE As Worksheet
    
    On Error Resume Next
    Set wsE = wbWB.Sheets(sName)
    On Error GoTo 0
    
    If Not wsE Is Nothing Then CheckSht = True
    
    
End Function