Excel VB Code Adjust for Splitting Into Separate Workbooks

Hello,

Seeking assistance for developing a VB code to help automate a process.  The attached spreadsheet has an existing code that breaks into smaller, individual workbooks based on changes in the ID (column C).  This part of the code is running as expected.

Based on an update I need an update to the code that will do the following BEFORE the majority of the data is split up into separate workbooks:

In column C, if the number is 000060 and the manager (column K) is Washington, George, take all applicable rows and place in a new workbook called 000060E.

In column C, if the number is 000060 and the manager (column K) is Washington, Martha, take all applicable rows and place in a new workbook called 000060A.

The selected rows in both conditions would be removed from the master file so they do not appear when the main code to split out the rest of the IDs is ran.  The ID and the manager must match.  Any remaining 000060 that do not match the conditions mentioned would remain on the master file.  So once the overall code is ran I would end up with a workbook 000060, 000060E and 000060A saved in a specified network folder.

Way beyond my limited coding skills and hoping the VB code ninjas can help.  Thank you for any assistance!
EE-Sample.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.

als315Commented:
Test this sample
EE-Sample1.xlsm
0
EscanabaManager - HR AnalyticsAuthor Commented:
Thank you for assisting.  A couple of things:
You indicated at the bottom of the code if I needed to utilize the password protection to remove the comments.  I do need the workbook protected with a password and the worksheets protected without a password.  So how that is set up in the existing code would still be required.

When I run your code after removing those comments it errors out highlighting this line at the bottom:
        wb.SaveAs Filepath & "\" & FileName, FileFormat:=51, ReadOnlyRecommended:=False, CreateBackup:=False

Also - if I want to replicate this process, meaning if I want to add more codes other than 000060 and George/Martha Washington what would be the best way to add those?  For example, 000070 and Lincoln, Abraham....how would add add that to what you created to make sure that is pulled into a separate workbook and removed from the master list before the main part of the code runs?
0
als315Commented:
If you need to protect only workbook, you need only one uncommented line:
 '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 & "\" & FileName, FileFormat:=51, ReadOnlyRecommended:=False, CreateBackup:=False

I have no errors
You can call sub with any codes, add line with call to sub and parameters:
Call c_000060(Filepath, ws1, "Lincoln, Abraham", "000070", "L")
file wil be 000070L.xls
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:
When I add that additional sub all it shows the 000060E and 000060A then it just locks in a loop.  Here is what I am using:


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

Filepath = "S:"

Call c_000060(Filepath, ws1, "Washington, George", "000060", "E")
Call c_000060(Filepath, ws1, "Washington, Martha", "000060", "A")
Call c_000060(Filepath, ws1, "Lincoln, Abraham", "000070", "M")


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

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

Sub c_000070(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
Dim wb As Workbook ', wks As Worksheet
WG = True
FileName = No & FileName
'Set wks = swb.Sheets(wksN)
SR = 14 'Correct if structure will be changed
SO = 2
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("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
    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 & "\" & FileName, FileFormat:=51, ReadOnlyRecommended:=False, CreateBackup:=False
       
       
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
End If
End Sub

Sub c_000070(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
Dim wb As Workbook ', wks As Worksheet
WG = True
FileName = No & FileName
'Set wks = swb.Sheets(wksN)
SR = 14 'Correct if structure will be changed
SO = 2
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("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
    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 & "\" & FileName, FileFormat:=51, ReadOnlyRecommended:=False, CreateBackup:=False
       
       
        wb.Close
        Application.DisplayAlerts = True
        Set wb = Nothing
End If
   
End Sub
0
als315Commented:
You don't need additional sub. Look at sample
There were also one error and some lines were not deleted. Use new sub c_000060
EE-Sample2.xlsm
0
EscanabaManager - HR AnalyticsAuthor Commented:
Ok - I see what you're doing now.  Everything appears to be working but there is one issue.  The new files being created from the new sub C are not copying over rows 1-12 at the top.  Its starting at row 13 but it should be copying everything that is in the master file starting at row 1 down to row 13 where the column headers are at.  If you run the file but remove this line:  Exit Sub 'remove this line after testing to run the full code and then open 000060E and then open 000002 you'll see the difference.  If that can be corrected then this should be ready for use.  Thank you.
0
als315Commented:
Look at sub: there is line with comment
SR = 14 'Correct if structure will be changed
Change 14 to real line (2, for example, if you have headers)
EE-Sample2.xlsm
0
EscanabaManager - HR AnalyticsAuthor Commented:
When I run your attached file (only change is adding a file path of where the new workbooks are being saved) it does not generate the new 000060E, 000060A and 000070L workbooks.
0
als315Commented:
Value of SR should be set to correct value (number of row with first line after header). I've also correccted error when path is with slash in the end
EE-Sample3.xlsm
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:
I appreciate your patience.  I need these 'sub workbooks' to appear just like the others when the full code is ran.  If I am understanding this correctly, I need to change SR to equal 1 as that is the first row in the master that needs to carry over.  When I do this it does not generate any of the sub workbooks and just runs the rest of the code.  Attached pic 1 shows how it looks in my folder when I run the code with SR=1 and pic 2 is a snapshot of how I changed the SR.  Im not sure what Im overlooking but I am guessing its something simple.  If you can change the code in an example file so when it runs the sub workbooks will show the full rows starting at row 1 from the master I can zero in on what I did incorrectly.  Thanks.
EE-Sample-1.jpg
EE-Sample-2.jpg
0
EscanabaManager - HR AnalyticsAuthor Commented:
So when I open 000060A, it should look like this attached sample in terms of having all the content in rows 1 - 13 with the new data based on what was defined in the sub code starting at line 14 down.
EE-Sample-3.jpg
0
als315Commented:
SR = 1 if threre are no headers. SR is the number of first line with data.
In saved workbook you will have only data and row with number equal SR -1
0
EscanabaManager - HR AnalyticsAuthor Commented:
So if Im understanding this correctly the way this code has been developed there is no way to carry over those rows (1-13) over to the new sub workbooks?
0
als315Commented:
Upload sample and I show you how to correct code.
0
EscanabaManager - HR AnalyticsAuthor Commented:
Thank you for all your help.  Finally pieced everything together.  Greatly appreciated!
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.