Consulting

Results 1 to 18 of 18

Thread: Split Workwook and save

  1. #1

    Split Workwook and save

    Hello there!

    I have a complex issue (for my standards), that I would like to resolve using VBA in Excel.

    I am a total VBA noob, only used it for simple macros so far, using internet sources.

    There are three worksheets in my workbook. (Data, Pivot and Dashboard)

    "Data" contains the data that the other worksheets are based on.

    “Pivot” contains Pivot tables based on "Data".

    “Dashboard” contains visualisations that change, depending on the item selected in cell C4. (the visualisations are based on the Pivot tables)

    I want to split the workbook in different workbooks based on the team (column A), so there should be 5 files in total (A, B, C, D, E). They should be encrypted with the passwords in column B.

    I found a code online doing exactly that:
    _____________________________
    Sub split()
    
    
    Dim MyDic As Object, rng As Range, Zelle As Range, ws As Worksheet, wb As Workbook
    Application.ScreenUpdating = False
    Set MyDic = CreateObject("Scripting.Dictionary")
    Set ws = ActiveSheet
    With ws
       Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
       For Each Zelle In rng.Offset(1, 0)
           If MyDic(Zelle.Value) = "" And Not IsEmpty(Zelle) Then
               MyDic(Zelle.Value) = 1
               rng.AutoFilter field:=1, Criteria1:=Zelle
               Set wb = Workbooks.Add
               .UsedRange.SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Cells(1, 1)
               wb.SaveAs Filename:=ThisWorkbook.Path & "" & Zelle & ".xlsx", FileFormat:=51, Password:=Cells(2, 2)
               wb.Close False
               rng.AutoFilter
           End If
       Next
    End With
    Application.ScreenUpdating = True
    End Sub
    ______________________________

    I implemented the “split” button in the data worksheet.

    Now the thing is, it only saves the respective rows from the "Data" worksheet", but the saved files should contain all three worksheets (Data, Pivot and Dashboard).

    Is it possible to do that using VBA?

    In the final files, each team should see the goals and hours played of their own team, but not the other teams.

    I also attached the excel file.

    And I apologize for my bad English.

    Thank you for your time and effort!

    Best Regards


    mojo-G

    PS. I use Microsoft office 365 / Excel 2302
    Attached Files Attached Files
    Last edited by Aussiebear; 03-10-2023 at 04:25 PM. Reason: Added code tags to supplied code

  2. #2
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    4,997
    Location
    Quote Originally Posted by mojogonzalez View Post
    PS. I use Microsoft office 365 / Excel 2302
    beta version perhaps???
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  3. #3
    Hello there,
    It is v2302 ( build 16130.20218 click to run edition).
    I get access to MS Office through my university, if that helps.




    BR

  4. #4
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    Maybe something like:
    Sub test()
        Dim unq As Variant, x As Integer, wb As Workbook
        
        unq = Application.Unique(Tabelle1.ListObjects("Tabelle1").ListColumns("Team").DataBodyRange)
        
        For x = 1 To UBound(unq)
            Sheets(Array("Data", "Pivot", "Dashboard")).Copy
            Set wb = ActiveWorkbook
            With ActiveSheet.ListObjects("Tabelle1")
                .Range.AutoFilter Field:=1, Criteria1:="<>" & unq(x, 1), Operator:=xlAnd
                Application.DisplayAlerts = False
                    .DataBodyRange.SpecialCells(xlVisible).Delete
                Application.DisplayAlerts = True
                .Range.AutoFilter Field:=1
            End With
            Sheets("Pivot").PivotTables("PivotTable1").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Pivot").PivotTables("PivotTable2").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Dashboard").Range("C4") = unq(x, 1)
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & unq(x, 1) & ".xlsx", FileFormat:=51, Password:=Cells(2, 2)
            wb.Close False
        Next x
    End Sub
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  5. #5

    Thank you!

    Quote Originally Posted by georgiboy View Post
    Maybe something like:
    Sub test()
        Dim unq As Variant, x As Integer, wb As Workbook
        
        unq = Application.Unique(Tabelle1.ListObjects("Tabelle1").ListColumns("Team").DataBodyRange)
        
        For x = 1 To UBound(unq)
            Sheets(Array("Data", "Pivot", "Dashboard")).Copy
            Set wb = ActiveWorkbook
            With ActiveSheet.ListObjects("Tabelle1")
                .Range.AutoFilter Field:=1, Criteria1:="<>" & unq(x, 1), Operator:=xlAnd
                Application.DisplayAlerts = False
                    .DataBodyRange.SpecialCells(xlVisible).Delete
                Application.DisplayAlerts = True
                .Range.AutoFilter Field:=1
            End With
            Sheets("Pivot").PivotTables("PivotTable1").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Pivot").PivotTables("PivotTable2").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Dashboard").Range("C4") = unq(x, 1)
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & unq(x, 1) & ".xlsx", FileFormat:=51, Password:=Cells(2, 2)
            wb.Close False
        Next x
    End Sub

    Hello,

    Thank you so much, that works!

    Just another question now:

    I tried it again on another Comnputer with a different excel Version (Microsoft Excel Professional Plus 2016 (16.0.5378.1000)

    Now there is a runtime error (438).

    And ideas what the problem could be?


    Best regards,

    Mojo-G

  6. #6
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    That will be the below line as it is not supported in older versions:
    unq = Application.Unique(Tabelle1.ListObjects("Tabelle1").ListColumns("Team").DataBodyRange)
    You can revert to your other method to get the list of unique items for older versions. I think you used the dictionary method.
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  7. #7
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    Could also use a loop with a collection to create the duplicate free list as below:
    Sub test()
        Dim x As Integer
        Dim wb As Workbook
        Dim rCell As Range
        Dim c As New Collection
        Dim col As Variant
        
        On Error Resume Next
        For Each rCell In Tabelle1.ListObjects("Tabelle1").ListColumns("Team").DataBodyRange.Cells
            c.Add rCell.Value, CStr(rCell.Value)
        Next rCell
        On Error GoTo 0
        
        For Each col In c
            Sheets(Array("Data", "Pivot", "Dashboard")).Copy
            Set wb = ActiveWorkbook
            With ActiveSheet.ListObjects("Tabelle1")
                .Range.AutoFilter Field:=1, Criteria1:="<>" & col, Operator:=xlAnd
                Application.DisplayAlerts = False
                .DataBodyRange.SpecialCells(xlVisible).Delete
                Application.DisplayAlerts = True
                .Range.AutoFilter Field:=1
            End With
            Sheets("Pivot").PivotTables("PivotTable1").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Pivot").PivotTables("PivotTable2").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Dashboard").Range("C4") = col
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & col & ".xlsx", FileFormat:=51, Password:=Cells(2, 2)
            wb.Close False
        Next col
    End Sub
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  8. #8
    Thank you for the quick response,

    Again I got the runtime erroe 438.

    unq = Application.Unique(Tabelle1.ListObjects("Tabelle1").ListColumns("Team").Dat aBodyRange)

    Thats the line that does not seem to be working, according to debugger.

    Best,

    Mojo-G


  9. #9
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    I did not use that line in my last post?
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  10. #10
    VBAX Regular
    Joined
    May 2018
    Location
    Sydney
    Posts
    57
    Location
    The code you provided only copies the filtered data from the "Data" worksheet. To include the "Pivot" and "Dashboard" worksheets as well, you can modify the code as follows:

    Sub split()
    
        Dim MyDic As Object, rng As Range, Zelle As Range, ws As Worksheet, wb As Workbook
        Application.ScreenUpdating = False
        Set MyDic = CreateObject("Scripting.Dictionary")
        Set ws = ThisWorkbook.Worksheets("Data")
        With ws
            Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
            For Each Zelle In rng.Offset(1, 0)
                If MyDic(Zelle.Value) = "" And Not IsEmpty(Zelle) Then
                    MyDic(Zelle.Value) = 1
                    rng.AutoFilter field:=1, Criteria1:=Zelle
                    Set wb = Workbooks.Add
                    
                    ' Copy "Data" worksheet
                    .UsedRange.SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Cells(1, 1)
                    wb.Sheets(1).Name = "Data"
                    
                    ' Copy "Pivot" and "Dashboard" worksheets
                    ThisWorkbook.Worksheets("Pivot").Copy After:=wb.Sheets(wb.Sheets.Count)
                    ThisWorkbook.Worksheets("Dashboard").Copy After:=wb.Sheets(wb.Sheets.Count)
                    
                    ' Save the new workbook
                    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & Zelle & ".xlsx", FileFormat:=51, Password:=Zelle.Offset(0, 1).Value
                    wb.Close False
                    rng.AutoFilter
                End If
            Next
        End With
        Application.ScreenUpdating = True
    
    
    End Sub
    This code will create new workbooks with all three worksheets (Data, Pivot, and Dashboard) for each team, and the data in the new workbooks will only show the respective team's data. The newly created workbooks will be encrypted with the passwords in column B.
    If you only ever do what you can , you'll only ever be what you are.

  11. #11
    Quote Originally Posted by Grade4.2 View Post
    The code you provided only copies the filtered data from the "Data" worksheet. To include the "Pivot" and "Dashboard" worksheets as well, you can modify the code as follows:

    Sub split()
    
        Dim MyDic As Object, rng As Range, Zelle As Range, ws As Worksheet, wb As Workbook
        Application.ScreenUpdating = False
        Set MyDic = CreateObject("Scripting.Dictionary")
        Set ws = ThisWorkbook.Worksheets("Data")
        With ws
            Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
            For Each Zelle In rng.Offset(1, 0)
                If MyDic(Zelle.Value) = "" And Not IsEmpty(Zelle) Then
                    MyDic(Zelle.Value) = 1
                    rng.AutoFilter field:=1, Criteria1:=Zelle
                    Set wb = Workbooks.Add
                    
                    ' Copy "Data" worksheet
                    .UsedRange.SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Cells(1, 1)
                    wb.Sheets(1).Name = "Data"
                    
                    ' Copy "Pivot" and "Dashboard" worksheets
                    ThisWorkbook.Worksheets("Pivot").Copy After:=wb.Sheets(wb.Sheets.Count)
                    ThisWorkbook.Worksheets("Dashboard").Copy After:=wb.Sheets(wb.Sheets.Count)
                    
                    ' Save the new workbook
                    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & Zelle & ".xlsx", FileFormat:=51, Password:=Zelle.Offset(0, 1).Value
                    wb.Close False
                    rng.AutoFilter
                End If
            Next
        End With
        Application.ScreenUpdating = True
    
    
    End Sub
    This code will create new workbooks with all three worksheets (Data, Pivot, and Dashboard) for each team, and the data in the new workbooks will only show the respective team's data. The newly created workbooks will be encrypted with the passwords in column B.
    Hello,

    Thank you for the quick response!

    The worksheet "data" only contains the Data of the respective team, thats perfect.

    Is it also possible for the other two worksheets to contain only the data of the team?

    So for example, to have the data of team C in "data", then in the "pivot" worksheet only the data of C, as well as in the Dashboard?

    Ideally, to have team C selcted in cell C4 of worksheet "Dashboard", so that the charts are updated as well?

    Thank you so much!

    Best,

    Mojo-G

  12. #12
    VBAX Regular
    Joined
    May 2018
    Location
    Sydney
    Posts
    57
    Location
    Can you please confirm if the below achieves the results you're after?

    Sub split()
    
        Dim MyDic As Object, rng As Range, Zelle As Range, ws As Worksheet, wb As Workbook
        Application.ScreenUpdating = False
        Set MyDic = CreateObject("Scripting.Dictionary")
        Set ws = ThisWorkbook.Worksheets("Data")
        With ws
            Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
            For Each Zelle In rng.Offset(1, 0)
                If MyDic(Zelle.Value) = "" And Not IsEmpty(Zelle) Then
                    MyDic(Zelle.Value) = 1
                    rng.AutoFilter field:=1, Criteria1:=Zelle
                    Set wb = Workbooks.Add
                    
                    ' Copy "Data" worksheet
                    .UsedRange.SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Cells(1, 1)
                    wb.Sheets(1).Name = "Data"
                    
                    ' Copy "Pivot" and "Dashboard" worksheets
                    ThisWorkbook.Worksheets("Pivot").Copy After:=wb.Sheets(wb.Sheets.Count)
                    ThisWorkbook.Worksheets("Dashboard").Copy After:=wb.Sheets(wb.Sheets.Count)
                    
                    ' Filter data in "Pivot" worksheet
                    On Error Resume Next
                    With wb.Worksheets("Pivot")
                        .PivotTables(1).PivotFields("Team").CurrentPage = Zelle.Value
                    End With
                    On Error GoTo 0
                    
                    ' Filter data and update charts in "Dashboard" worksheet
                    With wb.Worksheets("Dashboard")
                        .Range("C4").Value = Zelle.Value
                        .Calculate
                    End With
                    
                    ' Save the new workbook
                    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & Zelle & ".xlsx", FileFormat:=51, Password:=Zelle.Offset(0, 1).Value
                    wb.Close False
                    rng.AutoFilter
                End If
            Next
        End With
        Application.ScreenUpdating = True
    
    
    End Sub

  13. #13
    Quote Originally Posted by Grade4.2 View Post
    Can you please confirm if the below achieves the results you're after?

    Sub split()
    
        Dim MyDic As Object, rng As Range, Zelle As Range, ws As Worksheet, wb As Workbook
        Application.ScreenUpdating = False
        Set MyDic = CreateObject("Scripting.Dictionary")
        Set ws = ThisWorkbook.Worksheets("Data")
        With ws
            Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
            For Each Zelle In rng.Offset(1, 0)
                If MyDic(Zelle.Value) = "" And Not IsEmpty(Zelle) Then
                    MyDic(Zelle.Value) = 1
                    rng.AutoFilter field:=1, Criteria1:=Zelle
                    Set wb = Workbooks.Add
                    
                    ' Copy "Data" worksheet
                    .UsedRange.SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Cells(1, 1)
                    wb.Sheets(1).Name = "Data"
                    
                    ' Copy "Pivot" and "Dashboard" worksheets
                    ThisWorkbook.Worksheets("Pivot").Copy After:=wb.Sheets(wb.Sheets.Count)
                    ThisWorkbook.Worksheets("Dashboard").Copy After:=wb.Sheets(wb.Sheets.Count)
                    
                    ' Filter data in "Pivot" worksheet
                    On Error Resume Next
                    With wb.Worksheets("Pivot")
                        .PivotTables(1).PivotFields("Team").CurrentPage = Zelle.Value
                    End With
                    On Error GoTo 0
                    
                    ' Filter data and update charts in "Dashboard" worksheet
                    With wb.Worksheets("Dashboard")
                        .Range("C4").Value = Zelle.Value
                        .Calculate
                    End With
                    
                    ' Save the new workbook
                    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & Zelle & ".xlsx", FileFormat:=51, Password:=Zelle.Offset(0, 1).Value
                    wb.Close False
                    rng.AutoFilter
                End If
            Next
        End With
        Application.ScreenUpdating = True
    
    
    End Sub
    Hallo,

    It definetly goes in the right direction!

    So the Data worksheet gets saved exactly as it should.

    The other two need to be updated as well though.

    So the pivot should be based on the updated "Data" worksheet, containing only one specific them, so that the dashboard (based on the pivot) updates as well

    Thank you!

    Mojo-G

  14. #14
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    Quote Originally Posted by georgiboy View Post
    I did not use that line in my last post?
    ?
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  15. #15
    Quote Originally Posted by georgiboy View Post
    ?
    Yes you are right, I got mixed up with all the different Versions.

  16. #16
    The only problem is that the scource of the pivots is still the Table of the original file, but the pivots in each file should be linked to the tables in the individually saved files.

    So that also the pivots just show one team.

    Thank You!

  17. #17
    Quote Originally Posted by georgiboy View Post
    Maybe something like:
    Sub test()
        Dim unq As Variant, x As Integer, wb As Workbook
        
        unq = Application.Unique(Tabelle1.ListObjects("Tabelle1").ListColumns("Team").DataBodyRange)
        
        For x = 1 To UBound(unq)
            Sheets(Array("Data", "Pivot", "Dashboard")).Copy
            Set wb = ActiveWorkbook
            With ActiveSheet.ListObjects("Tabelle1")
                .Range.AutoFilter Field:=1, Criteria1:="<>" & unq(x, 1), Operator:=xlAnd
                Application.DisplayAlerts = False
                    .DataBodyRange.SpecialCells(xlVisible).Delete
                Application.DisplayAlerts = True
                .Range.AutoFilter Field:=1
            End With
            Sheets("Pivot").PivotTables("PivotTable1").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Pivot").PivotTables("PivotTable2").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Dashboard").Range("C4") = unq(x, 1)
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & unq(x, 1) & ".xlsx", FileFormat:=51, Password:=Cells(2, 2)
            wb.Close False
        Next x
    End Sub

    So far, this has produced the best result. The perfect result actually. However only in excel 2302 (Microsoft Office 365), not in Excel 2016.

    But I think I will just stick to Ecxel 2302 then.

    I also have one more question:

    Would you by any chance know how to edit the Code so that each individually saved file can be send to a specific recipient?

    For instance to have an individual text in column F and the respective email adress in column G with a Subject in column H?


    Thanks a lot to everyone!

  18. #18
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    Below is the code that was exactly the same but i removed the need to use version 2302:
    Sub test()
        Dim x As Integer
        Dim wb As Workbook
        Dim rCell As Range
        Dim c As New Collection
        Dim col As Variant
        
        On Error Resume Next
        For Each rCell In Tabelle1.ListObjects("Tabelle1").ListColumns("Team").DataBodyRange.Cells
            c.Add rCell.Value, CStr(rCell.Value)
        Next rCell
        On Error GoTo 0
        
        For Each col In c
            Sheets(Array("Data", "Pivot", "Dashboard")).Copy
            Set wb = ActiveWorkbook
            With ActiveSheet.ListObjects("Tabelle1")
                .Range.AutoFilter Field:=1, Criteria1:="<>" & col, Operator:=xlAnd
                Application.DisplayAlerts = False
                .DataBodyRange.SpecialCells(xlVisible).Delete
                Application.DisplayAlerts = True
                .Range.AutoFilter Field:=1
            End With
            Sheets("Pivot").PivotTables("PivotTable1").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Pivot").PivotTables("PivotTable2").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8)
            Sheets("Dashboard").Range("C4") = col
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & col & ".xlsx", FileFormat:=51, Password:=Cells(2, 2)
            wb.Close False
        Next col
    End Sub
    Last edited by georgiboy; 03-24-2023 at 02:00 AM.
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •