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:
_____________________________

Code:

---

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

Quote:

---

Originally Posted by mojogonzalez

PS. I use Microsoft office 365 / Excel 2302

---

beta version perhaps???

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

Maybe something like:

Code:

---

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

---

Quote:

---

Originally Posted by georgiboy

Maybe something like:

Code:

---

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

That will be the below line as it is not supported in older versions:

Code:

---

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.

Could also use a loop with a collection to create the duplicate free list as below:

Code:

---

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

---

Thank you for the quick response,

Again I got the runtime erroe 438.

Code:

---

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



---

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

Best,

Mojo-G

I did not use that line in my last 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:

Code:

---

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

Can you please confirm if the below achieves the results you're after?

Code:

---

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

---

Hello,

It definitely 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

Quote:

---

Originally Posted by georgiboy

I did not use that line in my last post?

---

?

Quote:

---

Originally Posted by georgiboy

?

---

Yes you are right, I got mixed up with all the different Versions.

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!

Quote:

---

Originally Posted by georgiboy

Maybe something like:

Code:

---

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!

Below is the code that was exactly the same but i removed the need to use version 2302:

Code:

---

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

---