Copy Active Worksheet to new workbook along with split by files

mlindquist

New Member
Joined
Sep 6, 2019
Messages
24
I have a workbook that has two sheets in it: Sheet1 = CoverSheet; Sheet2 = Data. I have a macro that I'm using to split Sheet2 (Data) into separate files based on a column (campus). So when the macro that splits the data based on column runs it only copies over to a new workbook Sheet2 with the filtered data for the campus. I would also like it to copy Sheet1 (Coversheet) into all of these workbooks. I tried to use ThisWorkbook.Sheets("Coversheet").Copy etc. but it didn't work.

Here is my VBA:

VBA Code:
VBA Code:
'****************************************************************
'

' Description:  Macro to Split spreadsheet by column name and create separate files
'               for each, no project specified
'
'****************************************************************

Private Sub cmdGo_Click()
 
    Dim TopRow As Integer
    Dim LastRow As Integer
    Dim WorkSheetName As String
    Dim WorkBookName As String
    Dim NewWorkBookName As String
    Dim CurrentValue As String
 
    Dim fc1 As Range
    Dim fc2 As Range
    Dim SortRange As String
      
    Dim Done As Integer
 
    'Get the name of the Workbook and Worksheet for later use
    WorkBookName = ActiveWorkbook.Name
    WorkSheetName = ActiveWorkbook.ActiveSheet.Name
 
    'Select all cells
    Cells.Select
    Rows(Trim(Str(Val(UserForm1.txtHeaderRows.Value) + 1)) & ":" & Trim(Str(Cells.Rows.Count))).Select

    'Sort by the column that was entered on the form
    SortRange = Trim(UserForm1.txtColumn.Value) & _
                Trim(Str(Val(UserForm1.txtHeaderRows.Value) + 1))
    Selection.Sort Key1:=Range(SortRange), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

    Done = 0
 
    'Get the key for the first set of data being captured
    CurrentValue = Cells(Val(UserForm1.txtHeaderRows.Value) + 1, UserForm1.txtColumn.Value)
 
    Do While Done = 0
        'Locate the first occurrence of the key value
        Set fc1 = Worksheets(WorkSheetName).Columns(UserForm1.txtColumn.Value).Find(what:=CurrentValue)
        TopRow = fc1.Row
      
        'Locate the last occurrence of the key value
        Range("A" & Cells.Rows.Count).Select
        Set fc2 = Worksheets(WorkSheetName).Columns(UserForm1.txtColumn.Value).FindPrevious
        LastRow = fc2.Row
      
        'Cut and paste the title and column widths to the new spreadsheet
        Rows("1:" & txtHeaderRows.Value).Select
        Application.CutCopyMode = False
      
        'Create a new workbook
        Workbooks.Add
        NewWorkBookName = ActiveWorkbook.Name
        Windows(WorkBookName).Activate
        Selection.Copy
        Windows(NewWorkBookName).Activate
        Range("A1").Select
      
        'Paste the Column Widths
        Selection.PasteSpecial Paste:=8, _
                                Operation:=xlNone, _
                                SkipBlanks:=False, _
                                Transpose:=False
        'Paste the Titles
        Selection.PasteSpecial Paste:=xlAll, _
                                Operation:=xlNone, _
                                SkipBlanks:=False, _
                                Transpose:=False
        Windows(WorkBookName).Activate
      
        'Select the data and paste to the new workbook
        Rows(TopRow & ":" & LastRow).Select
        Selection.Copy
        Windows(NewWorkBookName).Activate
        Range("A" & Trim(Str(Val(txtHeaderRows.Value) + 1))).Select
        Selection.PasteSpecial Paste:=xlAll, _
                                Operation:=xlNone, _
                                SkipBlanks:=False, _
                                Transpose:=False
        Application.CutCopyMode = False
      
        'Name the new workbook the same as the current workbook, just
        'append the key value at the end
        NewWorkBookName = Replace(WorkBookName, ".xlsx", "_" & CurrentValue & ".xlsx")
        NewWorkBookName = Replace(NewWorkBookName, ".XLSX", "_" & CurrentValue & ".XLSX")
        ActiveWorkbook.SaveAs _
            Filename:=txtDefaultPath.Value & NewWorkBookName, _
            Password:="", _
            WriteResPassword:="", _
            ReadOnlyRecommended:=False, _
            CreateBackup:=False
        ActiveWorkbook.Close
      
        'ActiveWorkbook.SaveAs _
        '    Filename:=txtDefaultPath.Value & NewWorkBookName, _
        '    FileFormat:=xlNormal, _
        '    Password:="", _
        '    WriteResPassword:="", _
        '    ReadOnlyRecommended:=False, _
        '    CreateBackup:=False
        'ActiveWorkbook.Close

      
        'Get the next Key value.  If blank, we're done
        CurrentValue = Cells(LastRow + 1, UserForm1.txtColumn.Value)
        If Trim(CurrentValue) = "" Then
          Done = 1
        End If
    Loop
    UserForm1.Hide
End Sub


Private Sub UserForm_Initialize()
    txtColumn.Value = "A"
    txtHeaderRows.Value = "1"
    txtDefaultPath.Value = "C:\"
End Sub
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
How about
VBA Code:
        NewWorkBookName = Replace(NewWorkBookName, ".XLSX", "_" & CurrentValue & ".XLSX")
        Worbooks(WorkBookName).Sheets("CoverSheet").Copy Workbooks(NewWorkBookName).Sheets(1)
        ActiveWorkbook.SaveAs _
 
Upvote 0
I received a Run-time error '9': Subscript out of range on this line -
Workbooks(WorkBookName).Sheets("CoverSheet").Copy Workbooks(NewWorkBookName).Sheets(1)

How about
VBA Code:
        NewWorkBookName = Replace(NewWorkBookName, ".XLSX", "_" & CurrentValue & ".XLSX")
        Worbooks(WorkBookName).Sheets("CoverSheet").Copy Workbooks(NewWorkBookName).Sheets(1)
        ActiveWorkbook.SaveAs _
 
Upvote 0
Do you have a sheet called CoverSheet in the workbook?
 
Upvote 0
Yes. I changed the location of where it is in the code to be before the naming of the new workbook and saving the new workbook.

VBA Code:
        'Select the data and paste to the new workbook
        Rows(TopRow & ":" & LastRow).Select
        Selection.Copy
        Windows(NewWorkBookName).Activate
        Range("A" & Trim(Str(Val(txtHeaderRows.Value) + 1))).Select
        Selection.PasteSpecial Paste:=xlAll, _
                                Operation:=xlNone, _
                                SkipBlanks:=False, _
                                Transpose:=False
        Application.CutCopyMode = False
        
        Workbooks(WorkBookName).Sheets("CoverSheet").Copy Workbooks(NewWorkBookName).Sheets(1)
        
        'Name the new workbook the same as the current workbook, just
        'append the key value at the end
        NewWorkBookName = Replace(WorkBookName, ".xlsx", "_" & CurrentValue & ".xlsx")
        NewWorkBookName = Replace(NewWorkBookName, ".XLSX", "_" & CurrentValue & ".XLSX")



But then a number of message boxes appear for each split file. I didn't see this before.

Message box appears - "Getting list of available content types and properties..."

And another message box - "Getting Content type definition."

Then a message box shows the new name that is uploading to the directory I specified.
 
Upvote 0
Are those from custom message boxes, or default Excel/VBA message boxes?
 
Upvote 0
Are those from custom message boxes, or default Excel/VBA message boxes?
They are from Excel/VBA. Maybe they come up behind the scenes and the macro runs so fast that I shouldn't be able to see it. But I'm on a limited internet working from home and we have already maxed out our bandwidth so things are running slower. So maybe I wouldn't see it if I was running it on internet where it is unlimited everything.
 
Upvote 0
In that case I'm not sure what they are, as I've never seen anything like before.
You could try putting this line before the copy line
VBA Code:
Application.DisplayAlerts=False
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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