Filter value -> create new workbook with only filtered value -> name the workbook as the value -> password protect -> save

[rainmaker1011]

Hi,

I would appreciate if you could help me with this.

I have a master excel workbook with multiple sheets:

"DATA", "INPUT", "NOTES"

DATA sheet is nicely formatted table with data and formulas referencing to INPUT and NOTES sheets.
DATA has a column A called "Manager". Values are names of managers.

I need to create new workbook for each Manager, and the new workbook should include

DATA, INPUT and NOTES sheets while in the DATA sheet should include the nicely formatted table, with all formulas intact but only the rows where Column A = manager name.

Then I need to name the workbook using the manager name and pass protect each workbook (same password) and save it on my drive.

Example:

Manager name = Peter, there are 10 rows with data with Manager name = Peter.

New workbook will be named Peter and it will include the sheets; DATA sheet will show the 10 rows.

----
I found macro that creates workbook from filtered data, but the process of filtering is manual. I have more than 150 different names that I need to filter so I need to automate that.

Thanks

 

[mumps]

You are very welcome.

 

[rainmaker1011]

You are very welcome.

I don't wanna sound ungrateful , but I have one last ask, hopefully

In my source file, I use Groupping of columns and I need to make sure they work also in the generated files, while the Sheet DATA is protected.

I have macro this macro that does that but it first must be in the Module of the file.

Private Sub Workbook_Open()
 For Each ws In Sheets
   With ws
   .Unprotect Password:="YourPassword"
   'enter your own password using quotation marks
   .Protect Password:="YourPassword", UserInterfaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
   .EnableOutlining = True
   End With
 Next ws
End Sub

The newly created files do not inherit the VBA code.

Can you help please?

Thanks.
Marek

 

[mumps]

Replace this line of code:

.SaveAs Filename:=sPath & v(i, 1) & ".xlsx", FileFormat:=51

with this one:

.SaveAs Filename:=sPath & v(i, 1) & ".xlsm", FileFormat:=52

 

[rainmaker1011]

Does not do the trick. The file saves as XLSM but Grouping does not work

 

[mumps]

The Workbook_Open macro you posted unprotects the sheets at the beginning but then protects them again at the end. Try replacing that macro with this one:

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    ActiveWorkbook.Unprotect Password:="YourPassword"
    For Each ws In Sheets
       With ws
           .Unprotect Password:="YourPassword"
       End With
    Next ws
    Application.ScreenUpdating = True
End Sub

and then try this revised macro:

Sub CreateWorkbooks()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, sPath As String, VBP As Object, codeto As Object, codefrom As Object, cnt As Long, srcWB As Workbook
    Set srcWB = ThisWorkbook
    sPath = "C:\Test\"
    v = Sheets("DATA").Range("F2", Sheets("DATA").Range("F" & Rows.Count).End(xlUp)).Value
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Sheets(Array("DATA", "INPUT", "NOTES")).Copy
                With Sheets("DATA")
                    .Range("A1").AutoFilter 6, "<>" & v(i, 1)
                    .AutoFilter.Range.Offset(1).EntireRow.Delete
                    .Range("A1").AutoFilter
                    .Range("A1").AutoFilter
                    .Protect Password:="YourPassword"
                    .EnableSelection = xlUnlockedCells
                    With ActiveWorkbook
                        Set codeto = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").codemodule
                        Set codefrom = srcWB.VBProject.VBComponents("ThisWorkbook").codemodule
                        sNewLine = codefrom.Lines(1, codefrom.CountOfLines)
                        With codeto
                            cnt = .CountOfLines + 1
                            .InsertLines cnt, sNewLine
                        End With
                        .Protect Password:="YourPassword", Structure:=True, Windows:=True
                        .SaveAs Filename:=sPath & v(i, 1) & ".xlsm", FileFormat:=52
                        .Close False
                    End With
                End With
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[rainmaker1011]

The Workbook_Open macro you posted unprotects the sheets at the beginning but then protects them again at the end. Try replacing that macro with this one:

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    ActiveWorkbook.Unprotect Password:="YourPassword"
    For Each ws In Sheets
       With ws
           .Unprotect Password:="YourPassword"
       End With
    Next ws
    Application.ScreenUpdating = True
End Sub

and then try this revised macro:

Sub CreateWorkbooks()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, sPath As String, VBP As Object, codeto As Object, codefrom As Object, cnt As Long, srcWB As Workbook
    Set srcWB = ThisWorkbook
    sPath = "C:\Test\"
    v = Sheets("DATA").Range("F2", Sheets("DATA").Range("F" & Rows.Count).End(xlUp)).Value
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Sheets(Array("DATA", "INPUT", "NOTES")).Copy
                With Sheets("DATA")
                    .Range("A1").AutoFilter 6, "<>" & v(i, 1)
                    .AutoFilter.Range.Offset(1).EntireRow.Delete
                    .Range("A1").AutoFilter
                    .Range("A1").AutoFilter
                    .Protect Password:="YourPassword"
                    .EnableSelection = xlUnlockedCells
                    With ActiveWorkbook
                        Set codeto = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").codemodule
                        Set codefrom = srcWB.VBProject.VBComponents("ThisWorkbook").codemodule
                        sNewLine = codefrom.Lines(1, codefrom.CountOfLines)
                        With codeto
                            cnt = .CountOfLines + 1
                            .InsertLines cnt, sNewLine
                        End With
                        .Protect Password:="YourPassword", Structure:=True, Windows:=True
                        .SaveAs Filename:=sPath & v(i, 1) & ".xlsm", FileFormat:=52
                        .Close False
                    End With
                End With
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

So I now have the codes in the Module 1 of the original master file, and this happens when I run CreateWorkbooks_NEW

In code form

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    ActiveWorkbook.Unprotect Password:="HBcomp22"
    For Each ws In Sheets
       With ws
           .Unprotect Password:="HBcomp22"
       End With
    Next ws
    Application.ScreenUpdating = True
End Sub

Sub CreateWorkbooks_NEW()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, sPath As String, VBP As Object, codeto As Object, codefrom As Object, cnt As Long, srcWB As Workbook
    Set srcWB = ThisWorkbook
    sPath = "C:\temp\"
    cPwd = "HBcomp22"
    v = Sheets("DATA").Range("I3", Sheets("DATA").Range("I" & Rows.Count).End(xlUp)).Value
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Sheets(Array("DATA", "INPUTS")).Copy
                With Sheets("DATA")
                    .Range("A3").AutoFilter 6, "<>" & v(i, 1)
                    .AutoFilter.Range.Offset(1).EntireRow.Delete
                    .Range("A3:AP3").AutoFilter
                    .Range("A3:AP3").AutoFilter
                    .Protect Password:="cPwd", AllowFiltering:=True
                    .EnableSelection = xlNoRestrictions
                    With ActiveWorkbook
                        Set codeto = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").codemodule
                        Set codefrom = srcWB.VBProject.VBComponents("ThisWorkbook").codemodule
                        sNewLine = codefrom.Lines(1, codefrom.CountOfLines)
                        With codeto
                            cnt = .CountOfLines + 1
                            .InsertLines cnt, sNewLine
                        End With
                        .Protect Password:="cPwd", Structure:=True, Windows:=True
                        .SaveAs Filename:=sPath & v(i, 1) & ".xlsm", FileFormat:=52
                        .Close False
                    End With
                End With
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[rainmaker1011]

So I now have the codes in the Module 1 of the original master file, and this happens when I run CreateWorkbooks_NEW

View attachment 82050
View attachment 82051

In code form

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    ActiveWorkbook.Unprotect Password:="HBcomp22"
    For Each ws In Sheets
       With ws
           .Unprotect Password:="HBcomp22"
       End With
    Next ws
    Application.ScreenUpdating = True
End Sub

Sub CreateWorkbooks_NEW()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, sPath As String, VBP As Object, codeto As Object, codefrom As Object, cnt As Long, srcWB As Workbook
    Set srcWB = ThisWorkbook
    sPath = "C:\temp\"
    cPwd = "HBcomp22"
    v = Sheets("DATA").Range("I3", Sheets("DATA").Range("I" & Rows.Count).End(xlUp)).Value
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Sheets(Array("DATA", "INPUTS")).Copy
                With Sheets("DATA")
                    .Range("A3").AutoFilter 6, "<>" & v(i, 1)
                    .AutoFilter.Range.Offset(1).EntireRow.Delete
                    .Range("A3:AP3").AutoFilter
                    .Range("A3:AP3").AutoFilter
                    .Protect Password:="cPwd", AllowFiltering:=True
                    .EnableSelection = xlNoRestrictions
                    With ActiveWorkbook
                        Set codeto = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").codemodule
                        Set codefrom = srcWB.VBProject.VBComponents("ThisWorkbook").codemodule
                        sNewLine = codefrom.Lines(1, codefrom.CountOfLines)
                        With codeto
                            cnt = .CountOfLines + 1
                            .InsertLines cnt, sNewLine
                        End With
                        .Protect Password:="cPwd", Structure:=True, Windows:=True
                        .SaveAs Filename:=sPath & v(i, 1) & ".xlsm", FileFormat:=52
                        .Close False
                    End With
                End With
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

Neverninde, I fixed it. It works just fine now Thanks

 

[mumps]

My pleasure.