Power User Challenge - Super complicated workbook split

[m5edward]

Hi Power Users,


So I have a bit of a challenge for a REAL Excel power user!

I need to split a workbook's multiple worksheets into multiple files (not based on worksheet name). Sound easy? Just wait.

The project: It deals with very sensitive HR/performance data, and I need to send 1000s of employees' data to their individual managers (about 100 managers who can only see their team's data, and no one else's), so I need about 100 files split (1 each for each manager).

The file:
- Many different tabs, separated by role.
- First column is a unique identifier made by concatenating the Manager's name with the job title ex. John Stevens_Office Manager

The task:
- John Stevens will have team members in many different job roles, and needs all that data in one file, separated into tabs by job role.

Sample Data

Tab 1: Office Manager
[TABLE="width: 500"]
<tbody>[TR]
[TD]Identifier[/TD]
[TD]Last Name[/TD]
[TD]First Name[/TD]
[TD]Performance[/TD]
[/TR]
[TR]
[TD]John Stevens_Office Manager[/TD]
[TD]Killjoy[/TD]
[TD]Heidi[/TD]
[TD]8/10[/TD]
[/TR]
[TR]
[TD]Lindsay Brown_Office Manager[/TD]
[TD]Wilcox[/TD]
[TD]Tommy[/TD]
[TD]9/10[/TD]
[/TR]
[TR]
[TD]Tom Fields_Office Manager[/TD]
[TD]Thorne[/TD]
[TD]Ronald[/TD]
[TD]7/10[/TD]
[/TR]
</tbody>[/TABLE]

Tab 2: Office Coordinator
[TABLE="width: 500"]
<tbody>[TR]
[TD]Identifier[/TD]
[TD]Last Name[/TD]
[TD]First Name[/TD]
[TD]Performance[/TD]
[/TR]
[TR]
[TD]John Stevens_Office Coordinator[/TD]
[TD]Shields[/TD]
[TD]Betty[/TD]
[TD]7/10[/TD]
[/TR]
[TR]
[TD]Lindsay Brown_Office Coordinator[/TD]
[TD]Johnson[/TD]
[TD]Craig[/TD]
[TD]9/10[/TD]
[/TR]
[TR]
[TD]Tom Fields_Office Coordinator[/TD]
[TD]Corgan[/TD]
[TD]Billy[/TD]
[TD]10/10[/TD]
[/TR]
</tbody>[/TABLE]

Tab 3: AR Associate
[TABLE="width: 500"]
<tbody>[TR]
[TD]Identifier[/TD]
[TD]Last Name[/TD]
[TD]First Name[/TD]
[TD]Performance[/TD]
[/TR]
[TR]
[TD]John Stevens_AR Associate[/TD]
[TD]Spears[/TD]
[TD]Britney[/TD]
[TD]4/10[/TD]
[/TR]
[TR]
[TD]Lindsay Brown_AR Associate[/TD]
[TD]Cobain[/TD]
[TD]Kurt[/TD]
[TD]10/10[/TD]
[/TR]
[TR]
[TD]Tom Fields_AR Associate[/TD]
[TD]Wilson[/TD]
[TD]Brian[/TD]
[TD]9/10[/TD]
[/TR]
</tbody>[/TABLE]


Based on that sample data, the ideal macro would give me 3 files with 3 worksheets in each, and 1 row of data in each worksheet. Ideally, the file name would just be the manager's name and the worksheets' names would be the job titles.


Ideally it would be nice to have one macro do all of this, but if it needs to be broken into 2 processes that's OK too. From my experience, this is a fairly common task for HR compensation analysts and you could probably sell this macro for $50. I know I'd buy it lol


Thanks,


Mark

 

[BiocideJ]

In the words of Barney Stinson, "Challenge Accepted!"


I believe this code will do pretty much what you are asking.

It is complicated to be sure, but I don't know about SUPER complicated. hehehe.
I'm sure if someone else takes a crack at it, they may come up with a more elegant solution, but mine should serve the purpose for specifically what you are doing.

Simply place this code in a module of your master file.

Sub HR_SPLIT_MASTER()
Dim a As Variant            'Array of manager/employee data
Dim i As Long, j As Long, k As Long    'Iterative variables
Dim R As Long
Dim fd As FileDialog
Dim folderName As String
Dim wbOut As Workbook
Dim wsOut As Worksheet
Dim fileName As String
    a = HR_File_Split()
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
    .Title = "Select the folder containing data"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo EXIT_BREAK
    folderName = .SelectedItems(1) & "\"
    End With
    
    
    'Iterate through each unique manager in array
    'Creating their unique lists and saving them
    For i = WorksheetFunction.Min(a) To WorksheetFunction.Max(a)
        Set wbOut = Workbooks.Add(1)
        
        
        For k = 1 To UBound(a, 2)
            If a(0, k) = i Then
            'THIS MANAGER IS PART OF CURRENT FILE
                If Not WorksheetExists(CStr(a(2, k))) Then
                    'NEED TO CREATE SHEET
                    Set wsOut = wbOut.Sheets.Add
                    wsOut.Name = a(2, k)
                    For j = 1 To UBound(a)
                        wsOut.Cells(1, j).Value = a(j, 0)
                    Next j
                    
                End If
                R = wsOut.Cells(Rows.Count, 1).End(xlUp).Row + 1
                For j = 1 To UBound(a)
                    wsOut.Cells(R, j).Value = a(j, k)
                Next j
                
                wsOut.Cells.EntireColumn.AutoFit
                fileName = a(1, k) & ".xlsx"
            End If
        Next k
        Application.DisplayAlerts = False
        wbOut.Sheets(wbOut.Sheets.Count).Delete 'delete the last (blank) sheet
        Application.DisplayAlerts = True
        wbOut.SaveAs folderName & fileName, 51
        'Stop
        wbOut.Close False
        Set wsOut = Nothing
        Set wbOut = Nothing
    Next i
    
EXIT_BREAK:
Set fd = Nothing
    
End Sub

Function HR_File_Split() As Variant
Dim Sht As Worksheet    'WORKSHEET
Dim R As Long           'ROW NUMBER
Dim unqMgrCount As Long
Dim i As Long, j As Long    'ITERATIVE VARIABLES
Dim columnCount As Long '# of columns being copied
'set this value to the number of COLUMNS to read.
'By rule, the first column is counted as TWO because it is used as both the MANAGER NAME and ROLE ([Sheet Name])
'I.e. A:D = 5 columns (4 + 1)
columnCount = 5
ReDim arrFile(0 To columnCount, 0 To 0) As Variant
'INITIALIZE HEADERS (BASED ON FIRST SHEET IN WORKBOOOK)
arrFile(0, 0) = "TMP_MGR_ID"
arrFile(1, 0) = "Manager Name"
arrFile(2, 0) = "Role"
For j = 3 To columnCount
    arrFile(j, 0) = ThisWorkbook.Sheets(1).Cells(1, j - 1).Value
Next j
    For Each Sht In ThisWorkbook.Sheets
        For R = 2 To Sht.Range("A" & Rows.Count).End(xlUp).Row
            
            'DETERMINE IF THIS MANAGER IS ALREADY IN LIST and set currMGRID accordingly
            currMGRID = unqMgrCount
            For i = LBound(arrFile, 2) To UBound(arrFile, 2)
                If Sht.Range("A" & R).Value Like arrFile(1, i) & "_*" Then
                    currMGRID = arrFile(0, i)
                End If
            Next i
            
            'INCREMENT unqMGRcount if manager is not already in array
            If currMGRID = unqMgrCount Then unqMgrCount = unqMgrCount + 1
            ReDim Preserve arrFile(0 To columnCount, 0 To UBound(arrFile, 2) + 1) As Variant
            arrFile(0, UBound(arrFile, 2)) = currMGRID
            arrFile(1, UBound(arrFile, 2)) = Replace(Replace(Sht.Cells(R, 1).Value, Sht.Name, ""), "_", "")
            arrFile(2, UBound(arrFile, 2)) = Sht.Name
            
            For j = 3 To columnCount
                arrFile(j, UBound(arrFile, 2)) = Sht.Cells(R, j - 1).Value
            Next j
            
        Next R
    Next Sht
HR_File_Split = arrFile
End Function

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

If you have any problems with the code, post back here and I will try to make revisions. Just try to be specific with what is going wrong.

As for that $50.
If this code works for you and you mean it is worth something, then I encourage you to pay it forward to some random stranger in a restaurant or behind you in a drive-thru.



NOTE: One thing I can't control is if there are two different managers with the same name. My macro will combine them as if they were the same person so hopefully there is some control in place on the workbook side of things to prevent this from happening.
NOTE#2: I noticed that when Excel is copy/pasting values of the type '4/10', '8/10', etc. that it translates them as DATES. Obviously this is going to be a problem, but I'm not sure if the source data can be amended to just be the initial value (i.e. 4, 8, etc.)

 

[m5edward]

OMG! Thank you so much!!! It's incredibly kind of you. I'm going to try this now, and if I have any problems I will be sure to let you know. Thanks again. The kindness of strangers is truly awe-inspiring, and even if it doesn't work, I'm going to give $50 to charity.

-Mark