none
I need a Macro to split this worksheet into multiple worksheets RRS feed

  • Question

  • I have a spreadsheet that contains multiple client codes.  I need to split this sheet into multiple sheets within the same file based on client code.  Each sheet can only contain one client, must be sorted by date, and at the bottom have each individual project listed and hours summed with a cell for each type of work and a total number of hours.  Project Numbers include NM, MP, PT, and PN.

    Example:

    Client Code Client Name Hours NM MP PT PN Type of Work Work Request # Description Date
    AAE Ardaman - Tallahassee   AAE 004 02 150 Clean 16-0845 na 1
    AAR Ardaman - Sarasota   AAR 001 01 123 Clean 16-3261 na 2
    A1CS A-1 Chipseal   A1CS 001 03 111 Clean 16-0007 na 3
    AAP A & A Asphalt Paving   AAP 100 04 116 Clean 16-0856 na 4
    AAP A & A Asphalt Paving   AAP 050 02 02 Clean 16-0695 na 2
    AAP A & A Asphalt Paving   AAP 004 02 03 Clean 16-0365 na 3

    Wednesday, May 18, 2016 9:46 PM

Answers

  • Hi jdangelo1981

    ,

    try to use the code mentioned below it can able to split the data In multiple sheets as per client code.

    Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 1
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:K1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    
    Range("K2:K7").Sort _
    Key1:=Range("K2"), Order1:=xlAscending
    
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
    End Sub
    Sub sb_VBA_Sort_Data_Descending()
    Range("K2:K7").Sort _
    Key1:=Range("K2"), Order1:=xlAscending
    End Sub

    Note:- This code is created on the bases of data mentioned above. so if the no of columns changed in your actual data then you need to modify the code. otherwise it will gives you an error.

    Regards

    Deepak


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Thursday, May 19, 2016 5:15 AM
    Moderator

All replies

  • Hi jdangelo1981

    ,

    try to use the code mentioned below it can able to split the data In multiple sheets as per client code.

    Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 1
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:K1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    
    Range("K2:K7").Sort _
    Key1:=Range("K2"), Order1:=xlAscending
    
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
    End Sub
    Sub sb_VBA_Sort_Data_Descending()
    Range("K2:K7").Sort _
    Key1:=Range("K2"), Order1:=xlAscending
    End Sub

    Note:- This code is created on the bases of data mentioned above. so if the no of columns changed in your actual data then you need to modify the code. otherwise it will gives you an error.

    Regards

    Deepak


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Thursday, May 19, 2016 5:15 AM
    Moderator
  • I am sure the author had solved the task long time ago, but for other visitors looking for the similar solution I can recommend to use XLTools Split Table tool:

    Here is how you can split a sample table mentioned by the author into a separate sheets grouped by "Client Code":

    Split master table into separate sheets by Client Code

    That is it. You can download a free trial version and give it a try: https://xltools.net/download/



    Thursday, July 13, 2017 5:24 PM