Renaming Worksheet VBA to insert in Longer VBA

K

kwoods117

New Member
Joined
Jul 14, 2021
Messages
4
Office Version
  1. 2016
Platform
  1. Windows
I am trying to split out a workbook with about 100 tabs into separate excel files, so I can PowerQuery them. I have it to the point where it splits out my files and renames them and puts them all in a folder, BUT I would LOVE if I could figure out how to also have the VBA rename the worksheet before it saves and closes. I need all of the worksheet tabs to have the same value so my PowerQuery will work. My workaround is opening and doing it manually.

This also creates an issue with the naming schema as it can't use the worksheet name as the filename. I would need to change it to pull the cell A2 value for the filename. I've tried for a couple hours, but I am an abused graphic designer and not an Excel expert. Help please?? Here's my VBA so far:

VBA Code: 
Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2013
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
kwoods117 said:
BUT I would LOVE if I could figure out how to also have the VBA rename the worksheet before it saves and closes.
Click to expand...

kwoods117 said:
I would need to change it to pull the cell A2 value for the filename.
Click to expand...
I do not understand. In the new book. What do you want to change, the name of the book or the name of the sheet?
The data for the name is taken from cell A2?
 
Upvote 0
DanteAmor said:
I do not understand. In the new book. What do you want to change, the name of the book or the name of the sheet?
The data for the name is taken from cell A2?
Click to expand...
I need to change the name of the sheet so that all of the various sheets in this project have the same name. However, the current VBA uses the sheet name to name the book. Since I can't have two files named the same thing, I was hoping I could change the VBA to name the book and therefore the file by the value of cell A2.

The current file I'm splitting out into separate files by worksheets:
1629930109509.png


How it looks when it is split out in the folder:
1629930133403.png


How I need the file with the "1" as the sheet name. Currently without fixing the VBA, the sheet names would be as above; in this case, 3.

1629930267427.png
 

Attachments

  • 1629930234719.png
    1629930234719.png
    34.9 KB · Views: 16
Upvote 0
I hope I have understood.
Try this:

VBA Code: 
Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2013
    Dim Sourcewb As Workbook, Destwb As Workbook
    Dim sh As Worksheet
    Dim FileExtStr As String, DateString As String, FolderName As String
    Dim FileFormatNum As Long
    
    Dim sNameBook As String, SNameSheet As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If
            
            With Destwb.Sheets(1)
              sNameBook = .Name
              SNameSheet = .Range("A2").Value   'or "1" or Or whatever name you want for the sheet
              .Name = SNameSheet
            End With
            'Save the new workbook and close it
            With Destwb
              .SaveAs FolderName & "\" & sNameBook & FileExtStr, _
                      FileFormat:=FileFormatNum
              .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
 
Upvote 0
My submission would be (note the separate functions):

VBA Code: 
Sub Copy_Every_Sheet_To_New_Workbook()
    'Working in 97-2013
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

' = = = = = = = = = = = =ADDED = = = = = = = = = =

    Dim FullName As String, FSO As Object, ShtCounter As Long, Status As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
' ================================================

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If

            'Save the new workbook and close it
            With Destwb

' = = = = = = = = = = = =ADDED = = = = = = = = = =
                ' get file name from currently exported worksheet's cell A2 and be sure it's a valid one

                FullName = ValidateFileName(Trim(.Sheets(1).Range("A2")))
                If FullName = vbNullString Then
                    FullName = FolderName & "\" & "SomeFileName" & FileExtStr
                Else
                    FullName = FolderName & "\" & FullName & FileExtStr
                End If

                ' do not error on duplicate file names
                If FSO.FileExists(FullName) Then
                    FullName = AddFileSuffix(FullName)
                End If
                ShtCounter = ShtCounter + 1
                Status = "Processing sheet " & ShtCounter & ": " & .Sheets(1).Name

                .Sheets(1).Name = "AnyNameYouWant"              ' <<<<<< sheet name (PowerQuery)
' ================================================
                
                .SaveAs FullName, FileFormat:=FileFormatNum     ' <<<<<<  changed
                .Close False
                
            End With
            
' = = = = = = = = = = = =ADDED = = = = = = = = = =
            With Application
                .ScreenUpdating = True
                .StatusBar = Status
                DoEvents
                .ScreenUpdating = False
            End With
' ================================================
        End If
GoToNextSheet:
    Next sh

    Application.StatusBar = False                                ' <<<<<<  added

    MsgBox "You can find the files in " & FolderName
    Shell "explorer.exe /root, " & FolderName, vbNormalFocus     ' <<<<<<  added
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub


Public Function ValidateFileName(ByVal argFileName As String) As String
    Const UNWANTEDCHARS As String = "<>""/:\|?*"
    Dim Result As String, i As Long
    Result = argFileName
    For i = 1 To Len(UNWANTEDCHARS)
        Result = Replace(Result, Mid(UNWANTEDCHARS, i, 1), "_")
    Next
    ValidateFileName = Result
End Function

Public Function AddFileSuffix(ByVal argFileName As String) As String
    Dim oFSO As Object, Pos As Long, File As String, Result As String
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Result = argFileName
    Pos = InStrRev(Result, ".")
    If Pos = 0 Then
        Result = IncreaseFileSuffix(Result)
    Else
        File = Left(Result, Pos - 1)
        If Len(File) = 0 Then
            File = IncreaseFileSuffix(Result)
        Else
            File = IncreaseFileSuffix(File)
        End If
        Result = File & "." & Right(Result, Len(Result) - Pos)
    End If
    If oFSO.FileExists(Result) Then
        AddFileSuffix = AddFileSuffix(Result)
    Else
        AddFileSuffix = Result
    End If
End Function

Public Function IncreaseFileSuffix(ByVal argFileName As String) As String
    Dim Sfx As String, Pos As Long
    If Not argFileName Like "*(*)" Then
        IncreaseFileSuffix = argFileName & "(1)"
    Else
        Pos = InStrRev(argFileName, "(") + 1
        Sfx = Mid(argFileName, Pos, Len(argFileName) - Pos)
        If IsNumeric(Sfx) Then
            IncreaseFileSuffix = Left(argFileName, Pos - 1) & (CLng(Sfx) + 1) & ")"
        Else
            IncreaseFileSuffix = argFileName & "(1)"
        End If
    End If
End Function
 
Upvote 0
Solution
GWteB said:
My submission would be (note the separate functions):

VBA Code: 
Sub Copy_Every_Sheet_To_New_Workbook()
    'Working in 97-2013
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

' = = = = = = = = = = = =ADDED = = = = = = = = = =

    Dim FullName As String, FSO As Object, ShtCounter As Long, Status As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
' ================================================

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If

            'Save the new workbook and close it
            With Destwb

' = = = = = = = = = = = =ADDED = = = = = = = = = =
                ' get file name from currently exported worksheet's cell A2 and be sure it's a valid one

                FullName = ValidateFileName(Trim(.Sheets(1).Range("A2")))
                If FullName = vbNullString Then
                    FullName = FolderName & "\" & "SomeFileName" & FileExtStr
                Else
                    FullName = FolderName & "\" & FullName & FileExtStr
                End If

                ' do not error on duplicate file names
                If FSO.FileExists(FullName) Then
                    FullName = AddFileSuffix(FullName)
                End If
                ShtCounter = ShtCounter + 1
                Status = "Processing sheet " & ShtCounter & ": " & .Sheets(1).Name

                .Sheets(1).Name = "AnyNameYouWant"              ' <<<<<< sheet name (PowerQuery)
' ================================================
               
                .SaveAs FullName, FileFormat:=FileFormatNum     ' <<<<<<  changed
                .Close False
               
            End With
           
' = = = = = = = = = = = =ADDED = = = = = = = = = =
            With Application
                .ScreenUpdating = True
                .StatusBar = Status
                DoEvents
                .ScreenUpdating = False
            End With
' ================================================
        End If
GoToNextSheet:
    Next sh

    Application.StatusBar = False                                ' <<<<<<  added

    MsgBox "You can find the files in " & FolderName
    Shell "explorer.exe /root, " & FolderName, vbNormalFocus     ' <<<<<<  added
   
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub


Public Function ValidateFileName(ByVal argFileName As String) As String
    Const UNWANTEDCHARS As String = "<>""/:\|?*"
    Dim Result As String, i As Long
    Result = argFileName
    For i = 1 To Len(UNWANTEDCHARS)
        Result = Replace(Result, Mid(UNWANTEDCHARS, i, 1), "_")
    Next
    ValidateFileName = Result
End Function

Public Function AddFileSuffix(ByVal argFileName As String) As String
    Dim oFSO As Object, Pos As Long, File As String, Result As String
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Result = argFileName
    Pos = InStrRev(Result, ".")
    If Pos = 0 Then
        Result = IncreaseFileSuffix(Result)
    Else
        File = Left(Result, Pos - 1)
        If Len(File) = 0 Then
            File = IncreaseFileSuffix(Result)
        Else
            File = IncreaseFileSuffix(File)
        End If
        Result = File & "." & Right(Result, Len(Result) - Pos)
    End If
    If oFSO.FileExists(Result) Then
        AddFileSuffix = AddFileSuffix(Result)
    Else
        AddFileSuffix = Result
    End If
End Function

Public Function IncreaseFileSuffix(ByVal argFileName As String) As String
    Dim Sfx As String, Pos As Long
    If Not argFileName Like "*(*)" Then
        IncreaseFileSuffix = argFileName & "(1)"
    Else
        Pos = InStrRev(argFileName, "(") + 1
        Sfx = Mid(argFileName, Pos, Len(argFileName) - Pos)
        If IsNumeric(Sfx) Then
            IncreaseFileSuffix = Left(argFileName, Pos - 1) & (CLng(Sfx) + 1) & ")"
        Else
            IncreaseFileSuffix = argFileName & "(1)"
        End If
    End If
End Function
Click to expand...

You're a genius! This one worked perfectly. Thank you SO MUCH!
 
Upvote 0
My pleasure and thanks for letting me know.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
VBA to save file to SharePoint and attach to outlook template saved in SharePoint
Replies
6
Views
282
Chris8630
C
M
  • Question Question
Email file VBA - change attachment from excel to PDF?
Replies
2
Views
364
MOB
M
H
  • Question Question
Macro to email Report
Replies
2
Views
588
howard
H
B
  • Solved
VBA copy Values exclude 1 column and formula
Replies
2
Views
318
bombergirl61
B
catscantuseexcel
  • Solved
VBA to send sheets based on column values
Replies
3
Views
967
DanteAmor
DanteAmor

Forum statistics

Threads
1,224,820
Messages
6,181,157
Members
453,021
Latest member
Justyna P

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