Excel VB Code Adjust to Split Into New Workbooks

Hello,

Please see the attached sample file.  The existing code works which splits out rows into separate workbooks based on an ID in column C.  Part of this code looks at specific IDs and if found groups them together and places them in a workbook called Ions.  

I am seeking assistance on modifying the code to replicate that process so if the macro also identifies rows with 000999 and 000998 then it places them into a workbook called Ions 2 and if it identifies rows with 000997 and 000996 then it places them into a workbook called Ions 3.

Thanks!
EE-Test-FileV2--1-.xlsm
LVL 1
EscanabaManager - HR AnalyticsAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
Hi,

pls try

Regards
EE-Test-FileV3.xlsm
0
EscanabaManager - HR AnalyticsAuthor Commented:
I apologize for the delay.  Been out of the office due to illness.  When I run the code I get an error stating 'Compile error:  Variable not defined' and highlights this part of the code:   bFound2 = True

ElseIf it = "000010" Or it = "000020" Or it = "000165" Then
        bFound = True
    ElseIf it = "000999" Or it = "000998" Then
      bFound2 = True
    ElseIf it = "000997" Or it = "000996" Then
        bFound3 = True

Open in new window

0
Rgonzo1971Commented:
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

EscanabaManager - HR AnalyticsAuthor Commented:
Do you know why the following is freezing up?  Based on your structure I thought everything was replicated but when I run it I get an error at   bFound4 = True stating its a compile error:  Variable not defined (line 103):


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
Dim bFound As Boolean, bFound2 As Boolean, bFound3 As Boolean
bFound = False

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 Salary Bands")

Filepath = "S:\Process Management\Ron Bayes\Projects\Compensation Merit File Duplication\"
Call c_000060(Filepath, ws1, "Schneider, Robert Douglas", "000070", "RDS")
Call c_000060(Filepath, ws1, "Walters, Dean P", "000070", "DPW")
Call c_000060(Filepath, ws1, "Morin, Jacky", "000095", "JM1")
Call c_000060(Filepath, ws1, "Morin, Jacky", "000103", "JM2")
Call c_000060(Filepath, ws1, "Schneider, Robert Douglas", "000075", "RDS")

Call c_000060(Filepath, ws1, "Nerud, Mark D", "000132", "MN")
Call c_000060(Filepath, ws1, "Rhee, Susan S", "000132", "SR")
Call c_000060(Filepath, ws1, "Collins, Maura K", "123200", "SR")


Call c_000060(Filepath, ws1, "Assaff, Anthony L", "000103", "OrgEff_TA")


'Exit Sub 'remove this line after testing

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
    If it <> "000010" And it <> "000020" And it <> "000159" And _
            it <> "000165" And it <> "000172" And _
            it <> "000173" And it <> "000174" And _
            it <> "000176" And it <> "000196" And _
            it <> "000201" And it <> "000205" And _
            it <> "000207" And it <> "000208" And _
            it <> "000209" And it <> "000053" And _
            it <> "000055" And it <> "000056" And _
            it <> "000057" And it <> "000058" And _
            it <> "000797" And it <> "000798" And _
            it <> "111400" And it <> "000066" And _
            it <> "000067" And it <> "000072" And _
            it <> "000073" And it <> "000075" And _
            it <> "007005" Then
        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)
            
                Sheets("Planning Worksheet").Select
                Range("L14").Select
            
            Application.DisplayAlerts = False
            
            wb.Protect Structure:=True, Windows:=False, Password:="Password"
            wb.Sheets(1).Protect
            wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
            wb.Close
            Application.DisplayAlerts = True
            Set wb = Nothing
            Application.CutCopyMode = 0
        End With
    ElseIf it = "000010" Or it = "000020" Or it = "000159" Or it = "000165" Or it = "000172" Or it = "000173" Or it = "000174" Or it = "000176" Or it = "000196" Or it = "000201" Or it = "000205" Or it = "000207" Or it = "000208" Or it = "000209" Then
        bFound = True
    ElseIf it = "000053" Or it = "000055" Or it = "000056" Or it = "000057" Or it = "000058" Then
        bFound2 = True
    ElseIf it = "000797" Or it = "000798" Or it = "111400" Then
        bFound3 = True
    ElseIf it = "000066" Or it = "000067" Or it = "000072" Or it = "000073" Or it = "000075" Then
        bFound4 = True
    ElseIf it = "007005" Then
        bFound5 = True
    End If
Next it

If bFound = True Then
    FileName = "O.xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000010", "000020", "000159", "000165", "000172", "000173", "000174", "000176", "000196", "000201", "000205", "000207", "000208", "000209"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If




If bFound2 = True Then
    FileName = "L.xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000053", "000055", "000056", "000057", "000058"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If




If bFound3 = True Then
    FileName = "N.xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000797", "000798", "111400"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If







If bFound4 = True Then
    FileName = "C"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000066", "000067", "000072", "000073", "000075"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If






If bFound5 = True Then
    FileName = "JN"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("007005"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If

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

Sub c_000060(Filepath As String, wks As Worksheet, Name As String, No As String, FileName As String)
Dim SR As Long, WG As Boolean, SO As Long, D As String
Dim wb As Workbook ', wks As Worksheet
WG = True
FileName = No & FileName
D = "\"
If Right(Filepath, 1) = "\" Then D = ""
'Set wks = swb.Sheets(wksN)
SR = 14 'Correct if structure will be changed
SO = 14
Do While wks.Cells(SR, 3) <> ""
    If wks.Cells(SR, 3) = No And wks.Cells(SR, 11) = Name Then
        If WG Then
            Set wb = Workbooks.Add
            WG = False
            wks.Rows("1:13").Copy wb.Sheets(1).Rows("1") 'Title
        End If
        wks.Rows(SR).Copy wb.Sheets(1).Rows(SO) 'insert row
        SO = SO + 1
        wks.Rows(SR).Delete
        SR = SR - 1
    End If
    SR = SR + 1
Loop
If Not WG Then
        Application.DisplayAlerts = False
        
        'Remove comments if you need password
        'wb.Protect Structure:=True, Windows:=False, Password:="Password"
       ' wb.Sheets(1).Protect
        'wb.SaveAs Filepath & "\" & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.SaveAs Filepath & D & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
End If
    
End Sub

Open in new window

0
Rgonzo1971Commented:
then 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
Dim bFound As Boolean, bFound2 As Boolean, bFound3 As Boolean, bFound4 As Boolean

bFound = False

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 Salary Bands")

Filepath = "S:\Process Management\Ron Bayes\Projects\Compensation Merit File Duplication\"
Call c_000060(Filepath, ws1, "Schneider, Robert Douglas", "000070", "RDS")
Call c_000060(Filepath, ws1, "Walters, Dean P", "000070", "DPW")
Call c_000060(Filepath, ws1, "Morin, Jacky", "000095", "JM1")
Call c_000060(Filepath, ws1, "Morin, Jacky", "000103", "JM2")
Call c_000060(Filepath, ws1, "Schneider, Robert Douglas", "000075", "RDS")

Call c_000060(Filepath, ws1, "Nerud, Mark D", "000132", "MN")
Call c_000060(Filepath, ws1, "Rhee, Susan S", "000132", "SR")
Call c_000060(Filepath, ws1, "Collins, Maura K", "123200", "SR")


Call c_000060(Filepath, ws1, "Assaff, Anthony L", "000103", "OrgEff_TA")


'Exit Sub 'remove this line after testing

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
    If it <> "000010" And it <> "000020" And it <> "000159" And _
            it <> "000165" And it <> "000172" And _
            it <> "000173" And it <> "000174" And _
            it <> "000176" And it <> "000196" And _
            it <> "000201" And it <> "000205" And _
            it <> "000207" And it <> "000208" And _
            it <> "000209" And it <> "000053" And _
            it <> "000055" And it <> "000056" And _
            it <> "000057" And it <> "000058" And _
            it <> "000797" And it <> "000798" And _
            it <> "111400" And it <> "000066" And _
            it <> "000067" And it <> "000072" And _
            it <> "000073" And it <> "000075" And _
            it <> "007005" Then
        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)
            
                Sheets("Planning Worksheet").Select
                Range("L14").Select
            
            Application.DisplayAlerts = False
            
            wb.Protect Structure:=True, Windows:=False, Password:="Password"
            wb.Sheets(1).Protect
            wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
            wb.Close
            Application.DisplayAlerts = True
            Set wb = Nothing
            Application.CutCopyMode = 0
        End With
    ElseIf it = "000010" Or it = "000020" Or it = "000159" Or it = "000165" Or it = "000172" Or it = "000173" Or it = "000174" Or it = "000176" Or it = "000196" Or it = "000201" Or it = "000205" Or it = "000207" Or it = "000208" Or it = "000209" Then
        bFound = True
    ElseIf it = "000053" Or it = "000055" Or it = "000056" Or it = "000057" Or it = "000058" Then
        bFound2 = True
    ElseIf it = "000797" Or it = "000798" Or it = "111400" Then
        bFound3 = True
    ElseIf it = "000066" Or it = "000067" Or it = "000072" Or it = "000073" Or it = "000075" Then
        bFound4 = True
    ElseIf it = "007005" Then
        bFound5 = True
    End If
Next it

If bFound = True Then
    FileName = "O.xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000010", "000020", "000159", "000165", "000172", "000173", "000174", "000176", "000196", "000201", "000205", "000207", "000208", "000209"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If




If bFound2 = True Then
    FileName = "L.xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000053", "000055", "000056", "000057", "000058"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If




If bFound3 = True Then
    FileName = "N.xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000797", "000798", "111400"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If







If bFound4 = True Then
    FileName = "C"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000066", "000067", "000072", "000073", "000075"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If






If bFound5 = True Then
    FileName = "JN"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("007005"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If

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

Sub c_000060(Filepath As String, wks As Worksheet, Name As String, No As String, FileName As String)
Dim SR As Long, WG As Boolean, SO As Long, D As String
Dim wb As Workbook ', wks As Worksheet
WG = True
FileName = No & FileName
D = "\"
If Right(Filepath, 1) = "\" Then D = ""
'Set wks = swb.Sheets(wksN)
SR = 14 'Correct if structure will be changed
SO = 14
Do While wks.Cells(SR, 3) <> ""
    If wks.Cells(SR, 3) = No And wks.Cells(SR, 11) = Name Then
        If WG Then
            Set wb = Workbooks.Add
            WG = False
            wks.Rows("1:13").Copy wb.Sheets(1).Rows("1") 'Title
        End If
        wks.Rows(SR).Copy wb.Sheets(1).Rows(SO) 'insert row
        SO = SO + 1
        wks.Rows(SR).Delete
        SR = SR - 1
    End If
    SR = SR + 1
Loop
If Not WG Then
        Application.DisplayAlerts = False
        
        'Remove comments if you need password
        'wb.Protect Structure:=True, Windows:=False, Password:="Password"
       ' wb.Sheets(1).Protect
        'wb.SaveAs Filepath & "\" & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.SaveAs Filepath & D & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
End If
    
End Sub

Open in new window

0
EscanabaManager - HR AnalyticsAuthor Commented:
Unfortunately I'm still getting the compile error stopping at bFound5 = True
0
Rgonzo1971Commented:
then 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
Dim bFound As Boolean, bFound2 As Boolean, bFound3 As Boolean, bFound4 As Boolean, bFound5 As Boolean

bFound = False

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 Salary Bands")

Filepath = "S:\Process Management\Ron Bayes\Projects\Compensation Merit File Duplication\"
Call c_000060(Filepath, ws1, "Schneider, Robert Douglas", "000070", "RDS")
Call c_000060(Filepath, ws1, "Walters, Dean P", "000070", "DPW")
Call c_000060(Filepath, ws1, "Morin, Jacky", "000095", "JM1")
Call c_000060(Filepath, ws1, "Morin, Jacky", "000103", "JM2")
Call c_000060(Filepath, ws1, "Schneider, Robert Douglas", "000075", "RDS")

Call c_000060(Filepath, ws1, "Nerud, Mark D", "000132", "MN")
Call c_000060(Filepath, ws1, "Rhee, Susan S", "000132", "SR")
Call c_000060(Filepath, ws1, "Collins, Maura K", "123200", "SR")


Call c_000060(Filepath, ws1, "Assaff, Anthony L", "000103", "OrgEff_TA")


'Exit Sub 'remove this line after testing

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
    If it <> "000010" And it <> "000020" And it <> "000159" And _
            it <> "000165" And it <> "000172" And _
            it <> "000173" And it <> "000174" And _
            it <> "000176" And it <> "000196" And _
            it <> "000201" And it <> "000205" And _
            it <> "000207" And it <> "000208" And _
            it <> "000209" And it <> "000053" And _
            it <> "000055" And it <> "000056" And _
            it <> "000057" And it <> "000058" And _
            it <> "000797" And it <> "000798" And _
            it <> "111400" And it <> "000066" And _
            it <> "000067" And it <> "000072" And _
            it <> "000073" And it <> "000075" And _
            it <> "007005" Then
        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)
            
                Sheets("Planning Worksheet").Select
                Range("L14").Select
            
            Application.DisplayAlerts = False
            
            wb.Protect Structure:=True, Windows:=False, Password:="Password"
            wb.Sheets(1).Protect
            wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
            wb.Close
            Application.DisplayAlerts = True
            Set wb = Nothing
            Application.CutCopyMode = 0
        End With
    ElseIf it = "000010" Or it = "000020" Or it = "000159" Or it = "000165" Or it = "000172" Or it = "000173" Or it = "000174" Or it = "000176" Or it = "000196" Or it = "000201" Or it = "000205" Or it = "000207" Or it = "000208" Or it = "000209" Then
        bFound = True
    ElseIf it = "000053" Or it = "000055" Or it = "000056" Or it = "000057" Or it = "000058" Then
        bFound2 = True
    ElseIf it = "000797" Or it = "000798" Or it = "111400" Then
        bFound3 = True
    ElseIf it = "000066" Or it = "000067" Or it = "000072" Or it = "000073" Or it = "000075" Then
        bFound4 = True
    ElseIf it = "007005" Then
        bFound5 = True
    End If
Next it

If bFound = True Then
    FileName = "O.xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000010", "000020", "000159", "000165", "000172", "000173", "000174", "000176", "000196", "000201", "000205", "000207", "000208", "000209"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If




If bFound2 = True Then
    FileName = "L.xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000053", "000055", "000056", "000057", "000058"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If




If bFound3 = True Then
    FileName = "N.xlsx"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000797", "000798", "111400"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If







If bFound4 = True Then
    FileName = "C"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("000066", "000067", "000072", "000073", "000075"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If






If bFound5 = True Then
    FileName = "JN"
    With ws1.Rows(13)
        .AutoFilter field:=3, Criteria1:=Array("007005"), Operator:=xlFilterValues
        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)
        
            Sheets("Planning Worksheet").Select
            Range("L14").Select
        
        Application.DisplayAlerts = False
        
        wb.Protect Structure:=True, Windows:=False, Password:="Password"
        wb.Sheets(1).Protect
        wb.SaveAs Filepath & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
        Application.CutCopyMode = 0
    End With
End If

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

Sub c_000060(Filepath As String, wks As Worksheet, Name As String, No As String, FileName As String)
Dim SR As Long, WG As Boolean, SO As Long, D As String
Dim wb As Workbook ', wks As Worksheet
WG = True
FileName = No & FileName
D = "\"
If Right(Filepath, 1) = "\" Then D = ""
'Set wks = swb.Sheets(wksN)
SR = 14 'Correct if structure will be changed
SO = 14
Do While wks.Cells(SR, 3) <> ""
    If wks.Cells(SR, 3) = No And wks.Cells(SR, 11) = Name Then
        If WG Then
            Set wb = Workbooks.Add
            WG = False
            wks.Rows("1:13").Copy wb.Sheets(1).Rows("1") 'Title
        End If
        wks.Rows(SR).Copy wb.Sheets(1).Rows(SO) 'insert row
        SO = SO + 1
        wks.Rows(SR).Delete
        SR = SR - 1
    End If
    SR = SR + 1
Loop
If Not WG Then
        Application.DisplayAlerts = False
        
        'Remove comments if you need password
        'wb.Protect Structure:=True, Windows:=False, Password:="Password"
       ' wb.Sheets(1).Protect
        'wb.SaveAs Filepath & "\" & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.SaveAs Filepath & D & FileName, FileFormat:=51, Password:="Password", WriteResPassword:="Password", ReadOnlyRecommended:=False, CreateBackup:=False
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
End If
    
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
EscanabaManager - HR AnalyticsAuthor Commented:
Perfect...Thank you (sorry for the delay I've been out for the holidays)
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.