Copy Worksheets that start with xxx to a new Workbook using a variable for the Workbook name

C

Chimelle

New Member
Joined
Oct 21, 2015
Messages
8
I am trying to copy worksheets within a workbook to new workbooks based on the value of the sheet name. So there could be any number of worksheets in the file, say 5 sheets start with the name Allegiance, 2 start with Express, and 3 start with McCollum. I want to copy, either a sheet at a time or loop through the sheets and based on the left 5 characters of the sheet name, copy the sheet into a workbook opened and saved with say 08.27.22 Allegiance or 08.27.22 Express. So I can't hard code the new workbook name because next week it will be 09.03.22 Allegiance. I keep getting runtime errors no matter what way I try. Can someone please get me going in the right direction.

Here is where I am currently at. I commented out a lot of it trying to get one portion to work.

VBA Code: 
Sub CreateFiles_TempLabor()

Dim ws As Worksheet
Dim origwb As Workbook
Dim strMonth As String
Dim strDay As String
Dim strYear As String


Fpath = ActiveWorkbook.Path
Set origwb = ActiveWorkbook

    Workbooks.Add
    Fpath = "J:\Temp Employment Agencies\Allegiance"
    dPreviousSaturday = Date - Weekday(Date)
    strMonth = Format(dPreviousSaturday, "mm")
    strDay = Format(dPreviousSaturday, "dd")
    strYear = Format(dPreviousSaturday, "yy")
    Fname = strMonth & "." & strDay & "." & strYear & " Allegiance"
    strFileName = Fpath & "\" & Fname & ".xlsx"
    strFileExists = Dir(strFileName)
    
    If strFileExists = "" Then
        ActiveWorkbook.SaveAs Filename:=Fpath & "\" & Fname & ".xlsx"
    Else
        ActiveWorkbook.SaveAs Filename:=Fpath & "\" & Fname & "_2.xlsx"
    End If
    
    wbAlleg = ActiveWorkbook.Name
    
'    Workbooks.Add
'    Fpath = "J:\Temp Employment Agencies\Express"
'    dPreviousSaturday = Date - Weekday(Date)
'    strMonth = Format(dPreviousSaturday, "mm")
'    strDay = Format(dPreviousSaturday, "dd")
'    strYear = Format(dPreviousSaturday, "yy")
'    Fname = strMonth & "." & strDay & "." & strYear & " Express"
'    strFileName = Fpath & "\" & Fname & ".xlsx"
'    strFileExists = Dir(strFileName)
'
'    If strFileExists = "" Then
'        ActiveWorkbook.SaveAs Filename:=Fpath & "\" & Fname & ".xlsx"
'    Else
'        ActiveWorkbook.SaveAs Filename:=Fpath & "\" & Fname & "_2.xlsx"
'    End If
'
'    wbExpre = ActiveWorkbook.Name
'
'    Workbooks.Add
'    Fpath = "J:\Temp Employment Agencies\McCollum"
'    dPreviousSaturday = Date - Weekday(Date)
'    strMonth = Format(dPreviousSaturday, "mm")
'    strDay = Format(dPreviousSaturday, "dd")
'    strYear = Format(dPreviousSaturday, "yy")
'    Fname = strMonth & "." & strDay & "." & strYear & " McCollum"
'    strFileName = Fpath & "\" & Fname & ".xlsx"
'    strFileExists = Dir(strFileName)
'
'    If strFileExists = "" Then
'        ActiveWorkbook.SaveAs Filename:=Fpath & "\" & Fname & ".xlsx"
'    Else
'        ActiveWorkbook.SaveAs Filename:=Fpath & "\" & Fname & "_2.xlsx"
'    End If
'
'    wbMcCol = ActiveWorkbook.Name
'
'    Workbooks.Add
'    Fpath = "J:\Temp Employment Agencies\Staffmark"
'    dPreviousSaturday = Date - Weekday(Date)
'    strMonth = Format(dPreviousSaturday, "mm")
'    strDay = Format(dPreviousSaturday, "dd")
'    strYear = Format(dPreviousSaturday, "yy")
'    Fname = strMonth & "." & strDay & "." & strYear & " Staffmark"
'    strFileName = Fpath & "\" & Fname & ".xlsx"
'    strFileExists = Dir(strFileName)
'
'    If strFileExists = "" Then
'        ActiveWorkbook.SaveAs Filename:=Fpath & "\" & Fname & ".xlsx"
'    Else
'        ActiveWorkbook.SaveAs Filename:=Fpath & "\" & Fname & "_2.xlsx"
'    End If
'
'    wbStaff = ActiveWorkbook.Name
    
origwb.Activate

For Each ws In ThisWorkbook.Worksheets
    agency = Left(ws.Name, 5)

     Select Case agency

            Case "Alleg"
                ws.Select
                ws.Copy After:=Workbooks(""", wbAlleg, """).Sheets(Sheet.count)

'            Case "Expre"
'                ws.Select
'                ws.Copy After:=workbookExpre.Sheets(Sheet.count)
'            Case "McCol"
'                ws.Select
'                ws.Copy After:=workbookMcCol.Sheets(Sheet.count)
'            Case "Staff"
'                ws.Select
'                ws.Copy After:=workbookStaff.Sheets(Sheet.count)
            Case Else

        End Select
Next ws

End Sub
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
What is the runtime error and at which line does it occur?
 
Upvote 0
It occurs at the Case When statement: ws.Copy After:=Workbooks(""", wbAlleg, """).Sheets(Sheet.count). I’ve gotten runtime error 424 and I believe the latest is runtime error 9.
 
Upvote 0
Not tested.

VBA Code: 
Sub CreateFiles_TempLabor()
    Dim ws As Worksheet
    Dim origwb As Workbook
    Dim strMonth As String
    Dim strDay As String
    Dim strYear As String
    Dim Fpath, dPreviousSaturday, Fname, strFileName, strFileExists, wbAlleg, agency, wbExpre, wbMcCol, wbStaff

    'Fpath = ActiveWorkbook.Path
    Set origwb = ActiveWorkbook

    dPreviousSaturday = Date - Weekday(Date)
    strMonth = Format(dPreviousSaturday, "mm")
    strDay = Format(dPreviousSaturday, "dd")
    strYear = Format(dPreviousSaturday, "yy")

    'Alleg
    Workbooks.Add
    Fpath = "J:\Temp Employment Agencies\Allegiance"
    Fname = strMonth & "." & strDay & "." & strYear & " Allegiance"

    strFileName = Fpath & "\" & Fname & ".xlsx"
    strFileExists = Dir(strFileName)
    With ActiveWorkbook
        If strFileExists = "" Then
            .SaveAs Filename:=Fpath & "\" & Fname & ".xlsx"
        Else
            .SaveAs Filename:=Fpath & "\" & Fname & "_2.xlsx"
        End If
        DoEvents
        wbAlleg = .Name
    End With

'    'Expre
'    Workbooks.Add
'    Fpath = "J:\Temp Employment Agencies\Express"
'    Fname = strMonth & "." & strDay & "." & strYear & " Express"
'
'    strFileName = Fpath & "\" & Fname & ".xlsx"
'    strFileExists = Dir(strFileName)
'    With ActiveWorkbook
'        If strFileExists = "" Then
'            .SaveAs Filename:=Fpath & "\" & Fname & ".xlsx"
'        Else
'            .SaveAs Filename:=Fpath & "\" & Fname & "_2.xlsx"
'        End If
'        DoEvents
'        wbExpre = .Name
'    End With
'
'    'McCol
'    Workbooks.Add
'    Fpath = "J:\Temp Employment Agencies\McCollum"
'    Fname = strMonth & "." & strDay & "." & strYear & " McCollum"
'
'    strFileName = Fpath & "\" & Fname & ".xlsx"
'    strFileExists = Dir(strFileName)
'    With ActiveWorkbook
'        If strFileExists = "" Then
'            .SaveAs Filename:=Fpath & "\" & Fname & ".xlsx"
'        Else
'            .SaveAs Filename:=Fpath & "\" & Fname & "_2.xlsx"
'        End If
'        DoEvents
'        wbMcCol = .Name
'    End With
'
'    'Staff
'    Workbooks.Add
'    Fpath = "J:\Temp Employment Agencies\Staffmark"
'    Fname = strMonth & "." & strDay & "." & strYear & " Staffmark"
'
'    strFileName = Fpath & "\" & Fname & ".xlsx"
'    strFileExists = Dir(strFileName)
'    With ActiveWorkbook
'        If strFileExists = "" Then
'            .SaveAs Filename:=Fpath & "\" & Fname & ".xlsx"
'        Else
'            .SaveAs Filename:=Fpath & "\" & Fname & "_2.xlsx"
'        End If
'        DoEvents
'        wbStaff = .Name
'    End With

    origwb.Activate

    For Each ws In ThisWorkbook.Worksheets
        agency = Left(ws.Name, 5)

        Select Case agency
        Case "Alleg"
            'ws.Select
            ws.Copy After:=Workbooks(wbAlleg).Sheets(Sheets.Count)
'        Case "Expre"
'            'ws.Select
'            ws.Copy After:=Workbooks(wbExpre).Sheets(Sheets.Count)
'        Case "McCol"
'            'ws.Select
'            ws.Copy After:=Workbooks(wbMcCol).Sheets(Sheets.Count)
'        Case "Staff"
'            'ws.Select
'            ws.Copy After:=Workbooks(wbStaff).Sheets(Sheets.Count)
'        'Case Else
        End Select
    Next ws
End Sub
 
Upvote 0
Use instead
VBA Code: 
ws.Copy After:=Workbooks(wbAlleg).Sheets(Workbooks(wbAlleg).Sheets.Count)
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

L
  • Question
Copy daily changing rows from a workbook paste to another workbook
Replies
1
Views
475
OaklandJim
O
D
  • Solved
Export and name sheets within a workbook to a text file in same directory as workbook
Replies
3
Views
516
rlv01
R
S
  • Solved
VBA copy template sheet to new monthly workbook with daily sheets tabname and header A2:J2 named as "dd mm yyyy" + autosave filename predefined
Replies
4
Views
581
mumps
mumps
Tim_D
  • Question
VBA Structure Best Practices and Code Review
2
Replies
13
Views
4K
dmt32
D
S
  • Question
I want to save activated worksheet at given folder path and want to save in tab with specific worksheet name using VBA macro
Replies
1
Views
385
sanju1988
S

Forum statistics

Threads
1,214,922
Messages
6,122,281
Members
449,075
Latest member
staticfluids

Share this page

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
Back
Top