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

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
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 Question
VBA to save newly created workbook failing - creates a "file" document
Replies
2
Views
210
Sunjinsak
S
B
  • Question Question
Copy and paste from one worksheet into a new workbook and save to a particular directory
Replies
3
Views
572
Joe4
Joe4
L
  • Question Question
Copy daily changing rows from a workbook paste to another workbook
Replies
1
Views
621
OaklandJim
O
D
  • Solved
Export and name sheets within a workbook to a text file in same directory as workbook
Replies
3
Views
773
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
790
mumps
mumps

Forum statistics

Threads
1,223,884
Messages
6,175,175
Members
452,615
Latest member
bogeys2birdies

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