Split Workwook and save

[mojogonzalez]

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

[Aussiebear]

PS. I use Microsoft office 365 / Excel 2302

beta version perhaps???

[mojogonzalez]

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

[georgiboy]

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

[mojogonzalez]

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

[georgiboy]

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.

[georgiboy]

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

[mojogonzalez]

Thank you for the quick response,

Again I got the runtime erroe 438.

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

[georgiboy]

I did not use that line in my last post?

[Grade4.2]

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.

[mojogonzalez]

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

[Grade4.2]

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

[mojogonzalez]

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

[georgiboy]

I did not use that line in my last post?

?

[mojogonzalez]

?

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

[mojogonzalez]

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!

[mojogonzalez]

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!

[georgiboy]

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