Split into separate worksheets based on two different columns

[mlindquist]

I currently have a macro to split data on one spreadsheet by one column - campus. I noticed when I was running the split macro I have that I also need to split on additional column - requestor - because there appears to be more than one requestor per campus and each final spreadsheet will be sent to the individual requestor to review the data and confirm that it looks good.

I was thinking that if I couldn't add this additional column in that maybe what I could do is have a macro create a new column that concatenates these values together then I could enter this new column in as the one to split on or something like that.

Here is my VBA:

Private Sub cmdGo_Click()
    
    Dim TopRow As Integer
    Dim LastRow As Integer
    Dim WorkSheetName As String
    Dim WorkBookName As String
    Dim NewWorkBookName As String
    Dim CurrentValue As String
    
    Dim fc1 As Range
    Dim fc2 As Range
    Dim SortRange As String
        
    Dim Done As Integer
    
    'Get the name of the Workbook and Worksheet for later use
    WorkBookName = ActiveWorkbook.Name
    WorkSheetName = ActiveWorkbook.ActiveSheet.Name
    
    'Select all cells
    Cells.Select
    Rows(Trim(Str(Val(UserForm1.txtHeaderRows.Value) + 1)) & ":" & Trim(Str(Cells.Rows.Count))).Select

    'Sort by the column that was entered on the form
    SortRange = Trim(UserForm1.txtColumn.Value) & _
                Trim(Str(Val(UserForm1.txtHeaderRows.Value) + 1))
    Selection.Sort Key1:=Range(SortRange), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

    Done = 0
    
    'Get the key for the first set of data being captured
    CurrentValue = Cells(Val(UserForm1.txtHeaderRows.Value) + 1, UserForm1.txtColumn.Value)
    
    'Get the sheet to also copy to new workbook
    CopySheetName1 = txtSheetName.Value
    CopySheetName2 = txtCopyTab1.Value

    
    Do While Done = 0
        'Locate the first occurrence of the key value
        Set fc1 = Worksheets(WorkSheetName).Columns(UserForm1.txtColumn.Value).Find(what:=CurrentValue)
        TopRow = fc1.Row
        
        'Locate the last occurrence of the key value
        Range("A" & Cells.Rows.Count).Select
        Set fc2 = Worksheets(WorkSheetName).Columns(UserForm1.txtColumn.Value).FindPrevious
        LastRow = fc2.Row
        
        'Cut and paste the title and column widths to the new spreadsheet
        Rows("1:" & txtHeaderRows.Value).Select
        Application.CutCopyMode = False
        
        'Create a new workbook
        Workbooks.Add
        NewWorkBookName = ActiveWorkbook.Name
        Windows(WorkBookName).Activate
        Selection.Copy
        Windows(NewWorkBookName).Activate
        Range("A1").Select
        
        'Paste the Column Widths
        Selection.PasteSpecial Paste:=8, _
                                Operation:=xlNone, _
                                SkipBlanks:=False, _
                                Transpose:=False
        'Paste the Titles
        Selection.PasteSpecial Paste:=xlAll, _
                                Operation:=xlNone, _
                                SkipBlanks:=False, _
                                Transpose:=False
        Windows(WorkBookName).Activate
        
        
        'Select the data and paste to the new workbook
        Rows(TopRow & ":" & LastRow).Select
        Selection.Copy
        Windows(NewWorkBookName).Activate
        Range("A" & Trim(Str(Val(txtHeaderRows.Value) + 1))).Select
        Selection.PasteSpecial Paste:=xlAll, _
                                Operation:=xlNone, _
                                SkipBlanks:=False, _
                                Transpose:=False
        Application.CutCopyMode = False
        
        
        'Copies the specified sheet to the new workbook as well - if blank ignores MKL
        'Workbooks(WorkBookName).Sheets("Cover Sheet").Copy Workbooks(NewWorkBookName).Sheets(1)
        If CopySheetName2 <> "" Then
        Workbooks(WorkBookName).Sheets(CopySheetName2).Copy Workbooks(NewWorkBookName).Sheets(1)
        End If
                
        'Name the new workbook the same as the current workbook, just
        'append the key value at the end
        NewWorkBookName = Replace(WorkBookName, ".xlsx", "_" & CurrentValue & ".xlsx")
        NewWorkBookName = Replace(NewWorkBookName, ".XLSX", "_" & CurrentValue & ".XLSX")
       ' Workbooks(NewWorkBookName).Worksheets(CopySheetName1).Activate
         
        ActiveWorkbook.SaveAs _
            Filename:=txtDefaultPath.Value & NewWorkBookName, _
            Password:="", _
            WriteResPassword:="", _
            ReadOnlyRecommended:=False, _
            CreateBackup:=False
        ActiveWorkbook.Close
        
       ' ActiveWorkbook.SaveAs _
       '     Filename:=txtDefaultPath.Value & NewWorkBookName, _
       '     FileFormat:=xlNormal, _
       '     Password:="", _
       '     WriteResPassword:="", _
       '     ReadOnlyRecommended:=False, _
       '     CreateBackup:=False
       ' ActiveWorkbook.Close

        
        'Get the next Key value.  If blank, we're done
        CurrentValue = Cells(LastRow + 1, UserForm1.txtColumn.Value)
        If Trim(CurrentValue) = "" Then
          Done = 1
        End If
    Loop
    UserForm1.Hide
End Sub


Private Sub Label5_Click()

End Sub

Private Sub Label6_Click()

End Sub

Private Sub UserForm_Initialize()
    txtColumn.Value = "A"
    txtHeaderRows.Value = "1"
    txtDefaultPath.Value = "C:\"
    txtSheetName = "By Transaction"
    txtCopyTab1 = ""
End Sub