Split into separate worksheets based on two different columns

mlindquist

New Member
Joined
Sep 6, 2019
Messages
15
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:

VBA Code:
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
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Watch MrExcel Video

Forum statistics

Threads
1,128,128
Messages
5,628,864
Members
416,346
Latest member
Sekolaine

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top