Rename Workbook Name with Entered value

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

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Maybe replacing this:
VBA Code:
      NewWorkBookName = ActiveWorkbook.Name
with something like this:
VBA Code:
        Dim newPrefix As String
        newPrefix = InputBox("What file name prefix would you like to use?")
        NewWorkBookName = newPrefix & " " & ActiveWorkbook.Name
 
Upvote 0

Forum statistics

Threads
1,223,909
Messages
6,175,310
Members
452,634
Latest member
cpostell

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