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