You are here:

Excel/Rename new WB created based on cell value

Advertisement


Question
Dear Bob,

I have an excel workbook, I created a macro to copy all sheets and save it as separate workbooks in new folder.
In this code, all created workbooks get the same name of included sheet.
My requirement is to give the new workbooks created a name based on cell (c2) value.


My code:

Sub Button4_Click()
   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


I think the trick should be in this part:

With Destwb
         .SaveAs FolderName _
         & "\" & Destwb.Sheets(1).Name & FileExtStr, _
         FileFormat:=FileFormatNum
         .Close False
End With

But when changing Destwb.sheets(1).name to Destwb.sheets(1).range("c2").value     code will stop..

Please help

Thanks

Answer
change
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
to
& "\" & Destwb.Sheets(1).Name & Destwb.Sheets(1).Range("C2").Value & FileExtStr, _


Perhaps the code stops (errors out?) depending on the vaue in C2...? Special characters like ":" or "\" not allowed.
About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Bob Umlas

Expertise

I`m a Microsoft Excel MVP (Most Valuable Professional) and have been since the inception of the program in 1995. I can answer every kind of Excel question except: API, Importing/exporting to other programs (powerpoint, word,...) Also check out my in-person training link at http://www.thumbtack.com/ny/new-york/excel-training/

Experience

Worked with MS Excel since version 0.99 (on the Mac!). Was contributing editor to Excellence Magazine, having written >300 articles. John Walkenbach said of me "I finally met someone who knows as much about Excel as I do."

Publications
Excellence, The Expert, Microsoft

Education/Credentials
BA in math, Hofstra University, 1965

Awards and Honors
MVP
Led sessions for the Convergence 2004-2006 seminar on Excel tips & tricks

©2016 About.com. All rights reserved.