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

R

rainmaker1011

New Member
Joined
Jan 2, 2023
Messages
11
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Sort by date Sort by votes
It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) 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.
 
Upvote 0
Hi rainmaker1011,

something like

VBA Code: 
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
 
Upvote 0
Thanks, see below


mumps said:
Book1.xlsx
ABCDEF
1IDCountrySalaryAnnual (Salary*12)CurrencyManager
21231DE120114412EURPeter
31251DE135216224EURPeter
41271DE150318036EURPeter
51291DE165419848EURPeter
61311DE180521660EURTom
71331DE195623472EURTom
81351DE210725284EURJohn
91371DE225827096EURJohn
101391UK240928908GBPSteve
111411UK256030720GBPSteve
121431UK271132532GBPJames
131451UK286234344GBPJames
141471UK500060000GBPJames
DATA
Cell Formulas
RangeFormula
D2:D14D2=C2*12
E2:E14E2=XLOOKUP(B2,INPUT!$B$2:$B$3,INPUT!$C$2:$C$3)
C3:C13C3=C2+151
Click to expand...
 
Upvote 0
HaHoBe said:
Hi rainmaker1011,

something like

VBA Code: 
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
Click to expand...
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.


1672676429525.png
 
Upvote 0
Change the path (in red) to suit your needs.
Rich (BB code): 
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
 
Upvote 0
mumps said:
Change the path (in red) to suit your needs.
Rich (BB code): 
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
Click to expand...
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
 
Upvote 0
Hi rainmaker1011,

maybe it's because of

VBA Code: 
      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
 
Upvote 0
Change the passwords (in red) to suit your needs.
Rich (BB code): 
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
 
Upvote 0
Solution
mumps said:
Change the passwords (in red) to suit your needs.
Rich (BB code): 
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
Click to expand...
You guys are great! Thanks Mumps :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Can a macro help create a user hierarchy?
Replies
7
Views
233
Akuini
Akuini
K
  • Question
Help with VB Code to copy workbook
Replies
0
Views
190
kizzie37
K
K
  • Question
VBA to filter Worksheet on manager column & copy all data to new workbook
Replies
8
Views
712
kizzie37
K
M
  • Question
Need to produce a couple workbooks..
Replies
5
Views
106
awoohaw
awoohaw
MikeMcCollister
  • Question
Copy Sheet Creates Copies of Lambda Functions in Name Manager
Replies
6
Views
193
MikeMcCollister
MikeMcCollister

Forum statistics

Threads
1,215,425
Messages
6,124,824
Members
449,190
Latest member
rscraig11

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top