PDA

View Full Version : Help with a VBA code to separate a workbook into many different files



Tira
07-17-2017, 12:48 PM
I have a previous code that I got off of here to separate the files that are in one workbook into several different ones and "save as" the name on the tab. Everything works find except it saves all the worksheets instead of one into each file. Can someone fix the code below so that only one tab is saved per file. Thanks!


Sub Test()


xPath = "G:\FSG\Howard\Monthly Bank Volume Reports\Bank Report Variance File\US Bank Reports - Bank\"
fileName = xPath & "\" & "US Bank Monthly Summary.xls"
Set wb = Workbooks.Open(fileName)

Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWorkbook.Save

xPath = Application.ActiveWorkbook.Path
fileName = Application.ActiveWorkbook.FullName

For MySheet = 1 To Sheets.Count
Sheets.Copy
Application.ActiveWorkbook.SaveAs fileName:=xPath & "/" & Sheets(MySheet).Name & ".xlsx"
Application.ActiveWorkbook.Close True
Next MySheet

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Logit
07-17-2017, 01:28 PM
.
Try this:



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 & " " & 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




Creates a separately named folder with date, containing all sheet copies. Folder is created in same location as the workbook.

Tira
07-18-2017, 06:49 AM
Unfortunately the code wouldn't work at all. Also, I wanted the files to save at the location from above. Here's the error message"Compile error: Wrong number of arguments or invalid property assignment.

Tira
07-19-2017, 11:58 AM
Can someone please help me tweak this first code above so that only one sheet is saved per file? Thanks!

Logit
07-19-2017, 01:30 PM
.
I am presuming your existing workbook is located in this path and named :

xPath = "G:\FSG\Howard\Monthly Bank Volume Reports\Bank Report Variance File\US Bank Reports - Bank\"
fileName = xPath & "\" & "US Bank Monthly Summary.xls"


If correct, this should work :




Option Explicit


Sub SveShts()


Dim xPath As String
Dim xWs As Worksheet


xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub