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



## rainmaker1011 (Jan 2, 2023)

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 (Jan 2, 2023)

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (*not a pictur*e) of your sheet.  Alternately, you could upload a copy of your file, (de-sensitized if necessary, to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.


----------



## HaHoBe (Jan 2, 2023)

Hi rainmaker1011,

something like


```
Public Sub MrE_1225853_1700211()
' https://www.mrexcel.com/board/threads/filter-value-create-new-workbook-with-only-filtered-value-name-the-workbook-as-the-value-password-protect-save.1225853/
' Created: 20230102
' By:      HaHoBe

'/// Please note: ALWAYS run the macros on a copy of your Workbook !!!!

  Dim wsData As Worksheet
  Dim rngCell As Range
  Dim lngCounter As Long
  Dim objDic As Object
  Dim wbNew As Workbook
  
  Set wsData = Worksheets("Data")
 
  Set objDic = CreateObject("scripting.dictionary")
  With wsData
    If .AutoFilterMode Then .AutoFilterMode = False
    For Each rngCell In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
      objDic.Item(rngCell.Value) = vbEmpty
    Next rngCell
    For lngCounter = 0 To objDic.Count - 1
      Worksheets(Split("INPUT,NOTES", ",")).Copy
      Set wbNew = ActiveWorkbook
      wbNew.Worksheets.Add before:=wbNew.Worksheets(1)
      ActiveSheet.Name = "Data"
      wsData.Rows(1).AutoFilter field:=1, Criteria1:=objDic.keys()(lngCounter)
      wsData.UsedRange.SpecialCells(xlCellTypeVisible).Copy
      ActiveSheet.Paste
      Application.CutCopyMode = False
      wbNew.SaveAs Filename:=Application.DefaultFilePath & "\" & objDic.keys()(lngCounter) & ".xlsx", FileFormat:=51, Password:="rainmaker1011"
      wbNew.Close True
    Next lngCounter
  End With
  
  Set wsData = Nothing
  Set wbNew = Nothing

End Sub
```

Ciao,
Holger


----------



## rainmaker1011 (Jan 2, 2023)

Thanks, see below




mumps said:


> Book1.xlsxABCDEF1IDCountrySalaryAnnual (Salary*12)CurrencyManager21231DE120114412EURPeter31251DE135216224EURPeter41271DE150318036EURPeter51291DE165419848EURPeter61311DE180521660EURTom71331DE195623472EURTom81351DE210725284EURJohn91371DE225827096EURJohn101391UK240928908GBPSteve111411UK256030720GBPSteve121431UK271132532GBPJames131451UK286234344GBPJames141471UK500060000GBPJamesDATACell FormulasRangeFormulaD2:D14D2=C2*12E2:E14E2=XLOOKUP(B2,INPUT!$B$2:$B$3,INPUT!$C$2:$C$3)C3:C13C3=C2+151


----------



## rainmaker1011 (Jan 2, 2023)

HaHoBe said:


> Hi rainmaker1011,
> 
> something like
> 
> ...


Hi Holger,

thanks for this. I tried it but I got an error.

Also in the "temporary" file I noticed that the formula was referencing to the original Book1 workbook. Which is not desirable.


----------



## mumps (Jan 2, 2023)

Change the path (in red) to suit your needs.

```
Sub CreateWorkbooks()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, sPath As String
    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
                    With ActiveWorkbook
                        .Protect Password:="YourPassword", Structure:=True, Windows:=True
                        .SaveAs Filename:=sPath & v(i, 1) & ".xlsx", FileFormat:=51
                        .Close False
                    End With
                End With
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub
```


----------



## rainmaker1011 (Jan 2, 2023)

mumps said:


> Change the path (in red) to suit your needs.
> 
> ```
> Sub CreateWorkbooks()
> ...


Cool, this works nice.

Can you please add:

- add filter to the 1st row of the newly created workbooks
- pass protect the sheet
- pass protect the file


Thanks a lot.
Marek


----------



## HaHoBe (Jan 2, 2023)

Hi rainmaker1011,

maybe it's because of 


```
wsData.Rows(1).AutoFilter field:=1, Criteria1:=objDic.keys()(lngCounter)
```

which will filter Column A (original request: _where Column A = manager name_) while you would need to filter Field:=6 (Column F) according to your sample later on.

Holger


----------



## mumps (Jan 2, 2023)

Change the passwords (in red) to suit your needs.

```
Sub CreateWorkbooks()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, sPath As String
    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
                        .Protect Password:="*YourPassword*", Structure:=True, Windows:=True
                        .SaveAs Filename:=sPath & v(i, 1) & ".xlsx", FileFormat:=51
                        .Close False
                    End With
                End With
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub
```


----------



## rainmaker1011 (Jan 3, 2023)

mumps said:


> Change the passwords (in red) to suit your needs.
> 
> ```
> Sub CreateWorkbooks()
> ...


You guys are great! Thanks Mumps


----------



## rainmaker1011 (Jan 2, 2023)

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 (Jan 3, 2023)

You are very welcome.


----------



## rainmaker1011 (Jan 3, 2023)

mumps said:


> 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 (Jan 3, 2023)

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 (Jan 3, 2023)

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


----------



## mumps (Jan 3, 2023)

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 (Jan 4, 2023)

mumps said:


> 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()
> ...



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 (Jan 4, 2023)

rainmaker1011 said:


> 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
> ...


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


----------



## mumps (Jan 6, 2023)

My pleasure.


----------

