Save worksheets as separate workbooks.

C

cdrobinson83

New Member
Joined
May 3, 2021
Messages
37
Office Version
  1. 365
Platform
  1. Windows
Hello,

I'd like to add a step to export worksheets as separate workbooks in a folder to the below macro. Important to note that I only want to export the worksheets that are created as part of the macro. The "Sheet1" I do NOT want to export. Can anyone please help with this?

VBA Code: 
Sub B_CREATE()
    Dim a, i&, ii&, s$, r As Range, c As Range, dic As Object
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    Set r = Sheets("sheet1").[a1].CurrentRegion '<--- Change sheet1 to actual source sheet name
    Set c = r.Offset(, r.Columns.Count + 2).Range("a1:a2")
    a = Application.Index(r, Application.Sequence(r.Rows.Count, , 1, 1), [{8,4,2,12}])
    For i = 2 To UBound(a, 1)
        s = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), "_")
        If Not dic.exists(s) Then
            dic(s) = Empty
            If Not Evaluate("isref('" & s & "'!a1)") Then
                Sheets.Add(, Sheets(Sheets.Count)).Name = s
            End If
            For ii = 1 To UBound(a, 2)
                If TypeName(a(i, ii)) = "String" Then a(i, ii) = Chr(34) & a(i, ii) & Chr(34)
            Next
            With Sheets(s)
                .UsedRange.CLEAR
                r.Rows(1).Copy .[a1]
                For ii = 1 To r.Columns.Count
                    .Columns(ii).ColumnWidth = r.Columns(ii).ColumnWidth
                Next
                c(2).Formula = "=and(h2=" & a(i, 1) & ",d2=" & a(i, 2) & ",b2=" & a(i, 3) & ",l2=" & a(i, 4) & ")"
                r.AdvancedFilter 2, c, .[a1].CurrentRegion
                With .Range("a" & Rows.Count).End(xlUp)(2, r.Columns.Count - 1).Resize(, 2)
                    .FormulaR1C1 = Array("Total", "=sum(r2c:r[-1]c)")
                    .Font.Bold = True
                    .Borders.Weight = 2
                    .Borders.ColorIndex = 15
                End With
            End With
        End If
    Next
    c.CLEAR
    Application.ScreenUpdating = True
End Sub
 
Sort by date Sort by votes
May be something like this,
VBA Code: 
Sub B_CREATE_And_Export()
    Dim a, i&, s$, r As Range, c As Range, dic As Object
    Dim newWb As Workbook, savePath As Variant
    
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    Set r = Sheets("Sheet1").[A1].CurrentRegion   ' <-- Change "Sheet1" to actual source sheet name
    Set c = r.Offset(, r.Columns.Count + 2).Range("A1:A2")
    a = Application.Index(r, Application.Sequence(r.Rows.Count, , 1, 1), [{8,4,2,12}])
    
    For i = 2 To UBound(a, 1)
        s = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), "_")
        If Not dic.exists(s) Then
            dic(s) = Empty
            Sheets.Add(, Sheets(Sheets.Count)).Name = s
            
            With Sheets(s)
                .UsedRange.Clear
                r.Rows(1).Copy .Range("A1")
                c(2).Formula = "=AND(H2=" & a(i, 1) & ",D2=" & a(i, 2) & ",B2=" & a(i, 3) & ",L2=" & a(i, 4) & ")"
                r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=c, CopyToRange:=.Range("A1"), Unique:=False
            End With
            
            Sheets(s).Copy
            Set newWb = ActiveWorkbook
            savePath = Application.GetSaveAsFilename( _
                        InitialFileName:=s & ".xlsx", _
                        FileFilter:="Excel Files (*.xlsx), *.xlsx", _
                        Title:="Export " & s)
            If savePath <> False Then
                newWb.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
                MsgBox "Worksheet " & s & " exported successfully to:" & vbCrLf & savePath
            Else
                MsgBox "Export of " & s & " canceled."
            End If
            newWb.Close SaveChanges:=False
        End If
    Next i
    
    c.Clear
    Application.ScreenUpdating = True
    MsgBox "Process complete."
End Sub
 
Upvote 0
Solution
Sam_D_Ben said:
May be something like this,
VBA Code: 
Sub B_CREATE_And_Export()
    Dim a, i&, s$, r As Range, c As Range, dic As Object
    Dim newWb As Workbook, savePath As Variant
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    Set r = Sheets("Sheet1").[A1].CurrentRegion   ' <-- Change "Sheet1" to actual source sheet name
    Set c = r.Offset(, r.Columns.Count + 2).Range("A1:A2")
    a = Application.Index(r, Application.Sequence(r.Rows.Count, , 1, 1), [{8,4,2,12}])
   
    For i = 2 To UBound(a, 1)
        s = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), "_")
        If Not dic.exists(s) Then
            dic(s) = Empty
            Sheets.Add(, Sheets(Sheets.Count)).Name = s
           
            With Sheets(s)
                .UsedRange.Clear
                r.Rows(1).Copy .Range("A1")
                c(2).Formula = "=AND(H2=" & a(i, 1) & ",D2=" & a(i, 2) & ",B2=" & a(i, 3) & ",L2=" & a(i, 4) & ")"
                r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=c, CopyToRange:=.Range("A1"), Unique:=False
            End With
           
            Sheets(s).Copy
            Set newWb = ActiveWorkbook
            savePath = Application.GetSaveAsFilename( _
                        InitialFileName:=s & ".xlsx", _
                        FileFilter:="Excel Files (*.xlsx), *.xlsx", _
                        Title:="Export " & s)
            If savePath <> False Then
                newWb.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
                MsgBox "Worksheet " & s & " exported successfully to:" & vbCrLf & savePath
            Else
                MsgBox "Export of " & s & " canceled."
            End If
            newWb.Close SaveChanges:=False
        End If
    Next i
   
    c.Clear
    Application.ScreenUpdating = True
    MsgBox "Process complete."
End Sub
Click to expand...

Thank you for your response! At first it was only copying the header of each tab, but I adjusted the code and it works now. Is it possible that instead of choosing the folder for each file, to set the location and create a new folder for each day? I'd also like to add a date to the end of each file if possible in yyyymmdd format. The date is always found in column S, row 2 of each tab being exported but it's in a different date format.


VBA Code: 
Sub B_CREATE_TEST()
    Dim a, i&, ii&, s$, r As Range, c As Range, dic As Object
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    Set r = Sheets("sheet1").[A1].CurrentRegion '<--- Change sheet1 to actual source sheet name
    Set c = r.Offset(, r.Columns.Count + 2).Range("a1:a2")
    a = Application.Index(r, Application.Sequence(r.Rows.Count, , 1, 1), [{8,4,2,12}])
    For i = 2 To UBound(a, 1)
        s = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), "_")
        If Not dic.exists(s) Then
            dic(s) = Empty
            If Not Evaluate("isref('" & s & "'!a1)") Then
                Sheets.Add(, Sheets(Sheets.Count)).Name = s
            End If
            For ii = 1 To UBound(a, 2)
                If TypeName(a(i, ii)) = "String" Then a(i, ii) = Chr(34) & a(i, ii) & Chr(34)
            Next
            With Sheets(s)
                .UsedRange.Clear
                r.Rows(1).Copy .[A1]
                For ii = 1 To r.Columns.Count
                    .Columns(ii).ColumnWidth = r.Columns(ii).ColumnWidth
                Next
                c(2).Formula = "=and(h2=" & a(i, 1) & ",d2=" & a(i, 2) & ",b2=" & a(i, 3) & ",l2=" & a(i, 4) & ")"
                r.AdvancedFilter 2, c, .[A1].CurrentRegion
                With .Range("a" & Rows.Count).End(xlUp)(2, r.Columns.Count - 1).Resize(, 2)
                    .FormulaR1C1 = Array("Total", "=sum(r2c:r[-1]c)")
                    .Font.Bold = True
                    .Borders.Weight = 2
                    .Borders.ColorIndex = 15
                End With
            End With
            
            Sheets(s).Copy
            Set newWb = ActiveWorkbook
            savePath = Application.GetSaveAsFilename( _
                        InitialFileName:=s & ".xlsx", _
                        FileFilter:="Excel Files (*.xlsx), *.xlsx", _
                        Title:="Export " & s)
            If savePath <> False Then
                newWb.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
                MsgBox "Worksheet " & s & " exported successfully to:" & vbCrLf & savePath
            Else
                MsgBox "Export of " & s & " canceled."
            End If
            newWb.Close SaveChanges:=False
            
        End If
    Next
    c.Clear
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Sum final column after creating worksheet
Replies
4
Views
179
cdrobinson83
C
R
  • Question Question
Required Transposed Values instead of Row Items of Duplicate Invoice no with Each GSTIN which is displaying the SUM of 12+18+28
Replies
1
Views
89
rk_rk
R
I
  • Solved
Msgbox is shown whether file is saved or not
Replies
4
Views
280
Alex Blakenburg
A
I
  • Question Question
File is allready saved but code should be stopping duplicates being saved
Replies
5
Views
329
ipbr21054
I
C
  • Question Question
Create a new row for every date in row and create multiple copies of data to new worksheet based on cell number value for each date in the row VBA
Replies
0
Views
193
Chris258
C

Forum statistics

Threads
1,226,850
Messages
6,193,333
Members
453,790
Latest member
yassinosnoo1

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top