Jun 17 2020 10:07 AM
Attached a copy of a Macro-enabled file I use to split out a master document into multiple individual workbooks. My question is for anyone familiar with Macros/VBA as I am not - I've only had this template for several years and just update the report format as need be - I would like to get the file naming portion of the routine to operate correctly.
Right now the macro sorts and filters the "Template" tab by Column A, and copies all rows with matching cell A data to a new book. Then that book is saved with a name that matches cell A exactly. I've screwed around with the VBA to try and get these to change to a concatenated name format that follows this form: YYYY-MM-DD-(Text of Cell A).xlsx
I know I can use the "Today()" function for the date, but translating this entire thing into the naming portion of the VBA is a bit above me. Suggestions anyone?
Jun 27 2020 10:24 AM
@JoeCavasin I think this file is working please check it out
Jun 27 2020 12:02 PM
If you wish, you may directly format the date in the code instead of reading the formatted date from the cell if it is always today's date like this...
dt = Format(Date, "yyyy-mm-dd ")
Sep 03 2020 12:46 PM
Thank you! the date will always be "today", works perfectly.
only other question - is it possible to have the sheet only make split copies for which there is data in column A? IE - the control sheet lists the 8 identifiers that may show up in column A, but not every run of this will have all 8 in column A. If on any given run only 2 or 3 of the identifiers are present, is it possible to have excel only split out to those two or three sheets, and not make all the other blank sheets?
Thanks
Sep 04 2020 01:31 AM
I have written the entire code from scratch. Please test it and let me know if that works fine on your end.
Sub Breakout()
Dim wsTemplate As Worksheet
Dim wsControl As Worksheet
Dim wbReport As Workbook
Dim Rng As Range
Dim Cel As Range
Dim lr As Long
Dim tlr As Long
Dim strFileName As String
Dim strFilePath As String
Dim dt As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wsTemplate = ThisWorkbook.Worksheets("Template")
Set wsControl = ThisWorkbook.Worksheets("Control")
If wsControl.Range("E1").Value = "" Then
MsgBox "Please input the path for the destination file in E1 on Control Sheet first and then try again...", vbExclamation
Exit Sub
End If
strFilePath = wsControl.Range("E1").Value
If Right(strFilePath, 1) <> "\" Then strFilePath = strFilePath & Application.PathSeparator
If Dir(strFilePath, vbDirectory) = "" Then
MsgBox "The folder " & strFilePath & " doesn't exist.", vbExclamation
Exit Sub
End If
dt = Sheets("Control").Range("E2").Value
wsTemplate.AutoFilterMode = False
tlr = wsTemplate.Cells(Rows.Count, 1).End(xlUp).Row
wsTemplate.Sort.SortFields.Clear
wsTemplate.Range("A1").Sort key1:=wsTemplate.Range("A2"), order1:=xlAscending, Header:=xlYes
lr = wsControl.Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = wsControl.Range("A2:A" & lr)
For Each Cel In Rng
If Cel.Value <> "" Then
wsTemplate.Rows(1).AutoFilter field:=1, Criteria1:=Cel.Value
If wsTemplate.Range("A1:A" & tlr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
strFileName = dt & Cel.Value & ".xls"
strFileName = strFilePath & strFileName
wsTemplate.Copy
Set wbReport = ActiveWorkbook
wbReport.SaveAs Filename:=strFileName, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
wbReport.Close True
End If
End If
Next Cel
If wsTemplate.FilterMode Then wsTemplate.ShowAllData
Application.DisplayAlerts = False
Application.ScreenUpdating = True
MsgBox "Task completed!", vbInformation
End Sub
In the attached, click the button called "Create Reports" on Control Sheet to run the code.
Dec 09 2020 04:30 PM
Evening Subodh, sorry to be so slow in testing this but other priorities took over the last few months. I did test it out today and it definitely runs smoother than my prior version and only outputs the number of files based on which id's are present in column A on the template tab. However one odd thing happened that I could not work around. The files exported were full copies of the data from the Template tab, however they were filtered down to a single identifier in column A. So instead of actually breaking out the data, they were just multiple copies, filtered down. Attaching the updated master copy and one output file as an example for review.
Thanks again!
Joe
Dec 09 2020 07:25 PM
Okya, try it like this...
Option Explicit
Sub Breakout()
Dim wsTemplate As Worksheet
Dim wsControl As Worksheet
Dim wbReport As Workbook
Dim wsReport As Worksheet
Dim Rng As Range
Dim Cel As Range
Dim lr As Long
Dim tlr As Long
Dim strFileName As String
Dim strFilePath As String
Dim dt As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wsTemplate = ThisWorkbook.Worksheets("Template")
Set wsControl = ThisWorkbook.Worksheets("Control")
If wsControl.Range("E1").Value = "" Then
MsgBox "Please input the path for the destination file in E1 on Control Sheet first and then try again...", vbExclamation
Exit Sub
End If
strFilePath = wsControl.Range("E1").Value
If Right(strFilePath, 1) <> "\" Then strFilePath = strFilePath & Application.PathSeparator
If Dir(strFilePath, vbDirectory) = "" Then
MsgBox "The folder " & strFilePath & " doesn't exist.", vbExclamation
Exit Sub
End If
dt = wsControl.Range("E2").Value
If IsDate(dt) = False Then
MsgBox "There is no date in cell E2 on Control Sheet.", vbExclamation, "Date Missing!"
Exit Sub
End If
wsTemplate.AutoFilterMode = False
tlr = wsTemplate.Cells(Rows.Count, 1).End(xlUp).Row
wsTemplate.Sort.SortFields.Clear
wsTemplate.Range("A1").Sort key1:=wsTemplate.Range("A2"), order1:=xlAscending, Header:=xlYes
lr = wsControl.Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = wsControl.Range("A2:A" & lr)
For Each Cel In Rng
If Cel.Value <> "" Then
wsTemplate.Rows(1).AutoFilter field:=1, Criteria1:=Cel.Value
If wsTemplate.Range("A1:A" & tlr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
strFileName = dt & Cel.Value & ".xls"
strFileName = strFilePath & strFileName
Set wbReport = Workbooks.Add
Set wsReport = wbReport.Worksheets(1)
wsReport.Name = "Template"
wsTemplate.Range("A1").CurrentRegion.Copy
wsReport.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
wsReport.Range("A1").PasteSpecial xlPasteColumnWidths
wsReport.Range("A1").PasteSpecial xlPasteFormats
Application.CutCopyMode = False
wbReport.SaveAs Filename:=strFileName, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
wbReport.Close True
End If
End If
Set wsReport = Nothing
Set wbReport = Nothing
Next Cel
If wsTemplate.FilterMode Then wsTemplate.ShowAllData
Application.DisplayAlerts = False
Application.ScreenUpdating = True
MsgBox "Task completed!", vbInformation
End Sub
Dec 10 2020 10:49 AM
Thanks Subodh, looks like it's heading the right direction. However now i'm getting the first file exported with only the data it should have, and then before it can save, immediately getting an "Error 400", and the whole thing stops?
-Joe