• Status: Solved
  • Priority: High
  • Security: Public
  • Views: 84
  • Last Modified:

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
0
Escanaba
Asked:
Escanaba
  • 4
  • 4
1 Solution
 
Rgonzo1971Commented:
Hi,

pls try

Regards
EE-Test-FileV3.xlsm
0
 
EscanabaAuthor 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
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
EscanabaAuthor 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
 
EscanabaAuthor 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
 
EscanabaAuthor Commented:
Perfect...Thank you (sorry for the delay I've been out for the holidays)
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: Ruby Fundamentals

This course will introduce you to Ruby, as well as teach you about classes, methods, variables, data structures, loops, enumerable methods, and finishing touches.

  • 4
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now