VB Macro to Hide Columns in New Workbooks and Format Adjustments

Escanaba
Escanaba used Ask the Experts™
on
Hello,

The attached sample has an existing macro which creates different workbooks based on the data in column C.  I am hoping someone can help add to this code by making the following updates:

1.  For every new workbook created the column width is expanded to 15
2.  For every new workbook created columns B, C, F, G H, I, O, P, T, U, V, X, AE, AJ and AK are hidden and locked.
3.  For every new workbook created the entire workbook is password protected.  Sample password can be:  password.

Any assistance would be greatly appreciated!  I am not very proficient in VB code and hoping some of you Excel/VB ninjas can figure this out.

Thank you.
EE-Sample.xlsm
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2016

Commented:
Hi,

pls try
Option Explicit

Sub CreateNewWorkbooks()
Dim swb As Workbook, wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lr As Long, i As Long
Dim FilePath As String, FileName As String
Dim x, dict, it

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set swb = ThisWorkbook
Set ws1 = swb.Sheets("Planning Worksheet")
Set ws2 = swb.Sheets("Instructions")
Set ws3 = swb.Sheets("2017 Band")

FilePath = "S:\File\"

ws1.AutoFilterMode = False
lr = ws1.Cells(Rows.Count, 3).End(xlUp).Row

x = ws1.Range("C14:C" & lr)
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    dict.Item(x(i, 1)) = ""
Next i

For Each it In dict.keys
    FileName = it & ".xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=it
        Set wb = Workbooks.Add
        ws1.Range("A1:AN" & lr).SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Range("A1")
        wb.Sheets(1).Name = ws1.Name
        wb.Sheets(1).UsedRange.ColumnWidth = 15
        With wb.Sheets(1).Range("B1,C1,E1,F1,G1,H1,I1,O1,P1,T1,U1,V1,X1,AE1,AJ1,AK1").EntireColumn
            .Locked = True
            .Hidden = True
        End With
        wb.Sheets(1).Protect Password:="password"
        ws2.Copy after:=wb.Sheets(Sheets.Count)
        ws3.Copy after:=wb.Sheets(Sheets.Count)

        wb.SaveAs FilePath & FileName, FileFormat:=51
        wb.Close
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
Next it
ws1.AutoFilterMode = False
Application.ScreenUpdating = True
Application.CutCopyMode = 0
MsgBox dict.Count & " Workbooks have been created and saved in the folder " & FilePath & "!", vbInformation
End Sub

Open in new window

Regards
EscanabaManager - HR Analytics

Author

Commented:
Hello - It throws up an error at line 39.  
The error states:  "Run-time error '1004':  Unable to set the Locked property of the Range class
Managing Director/Excel VBA Developer
Distinguished Expert 2018
Commented:
Hi,

Try below:
Option Explicit

Sub CreateNewWorkbooks()
Dim swb As Workbook, wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lr As Long, i As Long
Dim FilePath As String, FileName As String
Dim x, dict, it

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set swb = ThisWorkbook
Set ws1 = swb.Sheets("Planning Worksheet")
Set ws2 = swb.Sheets("Instructions")
Set ws3 = swb.Sheets("2017 Band")

FilePath = "S:\File\"

ws1.AutoFilterMode = False
lr = ws1.Cells(Rows.Count, 3).End(xlUp).Row

x = ws1.Range("C14:C" & lr)
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    dict.Item(x(i, 1)) = ""
Next i

For Each it In dict.keys
    FileName = it & ".xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=it
        Set wb = Workbooks.Add
        ws1.Range("A1:AN" & lr).SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Range("A1")
        wb.Sheets(1).Name = ws1.Name
        With wb.Sheets(1)
            .UsedRange.ColumnWidth = 15
            .Cells.Locked = False
            .Range("B:C,F:I,O:P,T:V,X:X,AE:AE,AJ:AK").Select
            .Range("F1").Activate
            Selection.Locked = True
            .Range("B:C,F:I,O:P,T:V,X:X,AE:AE,AJ:AK").EntireColumn.Hidden = True
        End With
        ws2.Copy after:=wb.Sheets(Sheets.Count)
        ws3.Copy after:=wb.Sheets(Sheets.Count)
        Application.DisplayAlerts = False
        wb.SaveAs FilePath & FileName, FileFormat:=51, Password:="password"
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
Next it
ws1.AutoFilterMode = False
Application.ScreenUpdating = True
Application.CutCopyMode = 0
MsgBox dict.Count & " Workbooks have been created and saved in the folder " & FilePath & "!", vbInformation
End Sub

Open in new window

EscanabaManager - HR Analytics

Author

Commented:
Thank you!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial