mlindquist
New Member
- Joined
- Sep 6, 2019
- Messages
- 24
So I have this macro where the main process is splitting an existing workbook that someone opens up by a column then creating new files with the column value in the name - currently it is taking the existing name and just appending to the end the column value. We want to be able to have our users enter the filename they wish (before the split value) - so for example if I had a column and it had states in it and the user wanted to name the file "Bubble Wrap Stats" then after the file is split a new file name would be called "Bubble Wrap Stats Illinois" (if the state value was Illinois), Bubble Wrap Stats Utah and so forth. I don't know why I'm overthinking this but I have tried a few things and it doesn't seem to want to work for me. Everytime I think I have it it just uses the file name I enter and not append the column values at the end.
Below is my current code:
Below is my current code:
VBA Code:
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)
'Get the sheet to also copy to new workbook
MainCopySheet = txtSplitSheet.Value
CopySheetName1 = txtCopySheet1.Value
CopySheetName2 = txtCopySheet2.Value
CopySheetName3 = txtCopySheet3.Value
CopySheetName4 = txtCopySheet4.Value
NewFilename = txtNewFilename.Value
DeleteColumn = txtDeleteColumn.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
'Copies the specified sheet to the new workbook as well - if blank ignores MKL
'Workbooks(WorkBookName).Sheets("Cover Sheet").Copy Workbooks(NewWorkBookName).Sheets(1)
If CopySheetName1 <> "" Then
Workbooks(WorkBookName).Sheets(CopySheetName1).Copy Workbooks(NewWorkBookName).Sheets(1)
End If
If CopySheetName2 <> "" Then
Workbooks(WorkBookName).Sheets(CopySheetName2).Copy Workbooks(NewWorkBookName).Sheets(1)
End If
If CopySheetName3 <> "" Then
Workbooks(WorkBookName).Sheets(CopySheetName3).Copy Workbooks(NewWorkBookName).Sheets(1)
End If
If CopySheetName4 <> "" Then
Workbooks(WorkBookName).Sheets(CopySheetName4).Copy Workbooks(NewWorkBookName).Sheets(1)
End If
' MKL 11/17/2021
Sheets("Sheet1").Name = "Template"
'Delete the Business Unit column before saving - added by Maria Lindquist 11/17/2021
If DeleteColumn <> "" Then
Sheets("Template").Select
' Columns(DeleteColumn & ":" & DeleteColumn).Delete
Columns(DeleteColumn & ":" & DeleteColumn).Select
Selection.Delete Shift:=xlToLeft
End If
'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")
' Workbooks(NewWorkBookName).Worksheets(CopySheetName1).Activate
' ActiveWorkbook.SaveAs _
' Filename:=txtDefaultPath.Value & NewWorkBookName, _
' Password:="", _
' WriteResPassword:="", _
' ReadOnlyRecommended:=False, _
' CreateBackup:=False
' ActiveWorkbook.Close
ActiveWorkbook.SaveAs _
Filename:=txtDefaultPath.Value & "\" & NewWorkBookName, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Close
'MKL11172021 Commented out for Compatibilty Check?
'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