VBA Code to rename workbook after worksheet name or specific cell value

[Oliver962]

Hey,

This is my first time posting here. I am an absolute newb when it comes to VBA. I am trying to build a macro that will copy a worksheet from a large workbook into a new workbook and then rename that workbook after a specified cell value so that all I need to do is save as, without having to type out the new file name for each. This macro will take each sheet from a workbook containing multiple sheets and put each into its' own workbook. So far I have gotten to the point where I can get each sheet into its' own workbook. I just need to figure out how to get it to rename the workbook.

Thanks so much

 

[rlv01]

You should probably post your code creating the new workbook(s) so we can see where the renaming code needs to go.

 

[rlv01]

How to post your code using code tags:

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com

 

[Logit]

The following will take each sheet ... transform it to a separate workbook named for value in cell B3. Edit the cell location as desired.

Option Explicit

Sub SplitWorkbook()
'Updateby20140612
Dim FileExtStr, DateString, xFile As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hhmm")
FolderName = xWb.Path & "\" & xWb.Name & " " & Range("B3").Value  'DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
    xWs.Copy
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.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
    xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
    Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
    Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub