daviddiebel
asked on
How to save each worksheet with a name containing a specific character string as a new workbook?
This is a pretty specific question. I use a workbook that contains a large number of worksheets. Most of the worksheets are named "Profile1," "Profile2," and so on - all with names containing the word "profile"
If I make minor edits to one worksheet, all the "profile" worksheets update simultaneously. I need to regularly export each of the "profile" worksheets to new, separate workbook files - one worksheet for each new workbook. So, each worksheet with a name containing the character string "profile" would need to be exported/saved as a workbook, while the other worksheets would not need to be exported.
And, preferably, each new workbook would be named according to the text contained in cell A1 of the worksheet being exported.
Thank you for your assistance!
If I make minor edits to one worksheet, all the "profile" worksheets update simultaneously. I need to regularly export each of the "profile" worksheets to new, separate workbook files - one worksheet for each new workbook. So, each worksheet with a name containing the character string "profile" would need to be exported/saved as a workbook, while the other worksheets would not need to be exported.
And, preferably, each new workbook would be named according to the text contained in cell A1 of the worksheet being exported.
Thank you for your assistance!
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Ooopps, that's a bit of a shocker, I should have tested the code - esp as I often mess up the order of the arguments of the Instr function.
Oh well, I'm pleased I could point you in the right direction :-)
Rob
Oh well, I'm pleased I could point you in the right direction :-)
Rob
ASKER
Option Explicit
Sub Copy_Every_Sheet_To_New_Wo
'24/05/2012, RB: sourced & modified from http://www.rondebruin.nl/copy6.htm
'Working in 97-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
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
FolderName = Sourcewb.Path & Application.PathSeparator
'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets
'If the sheet contains "profile" in its name then copy it to a new workbook
If InStr(sh.Name, "Profile") 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-2010
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
'Save the new workbook and close it
.SaveAs FolderName _
& Destwb.Sheets(1).Range("a1
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
Set Sourcewb = Nothing
Set Destwb = Nothing
End Sub