VBA code to split worksheet by invoice type

Would love to see how it looks. Going forward, I would love to learn how to explore the special features of "pivot tables". From your advice, i realised i could do more with PivotTables.

How do I parse the invoice numbers please? I tried using the long formula below

=IF(ISNUMBER(SEARCH("NPDC",A2,1))=TRUE,"NPDC",IF(ISNUMBER(SEARCH("FIRS",A2,1))=TRUE,"FIRS",IF(ISNUMBER(SEARCH("DSDP",A2,1))=TRUE,"DSDP",IF(ISNUMBER(SEARCH("DPR",A2,1))=TRUE,"DPR",IF(ISNUMBER(SEARCH("MCA",A2,1))=TRUE,"MCA",IF(ISNUMBER(SEARCH("RA",A2,1))=TRUE,"RA",IF(ISNUMBER(SEARCH("2020 -",A2,1))=TRUE,"JVC",IF(ISNUMBER(SEARCH("NNPC",A2,1))=TRUE,"EF",IF(ISNUMBER(SEARCH("COS",A2,1))=TRUE,"JP MORGAN",IF(ISNUMBER(SEARCH("NGCL",A2,1))=TRUE,"Dom Gas",IF(ISNUMBER(SEARCH("GS",A2,1))=TRUE,"NGL","Feedstock")))))))))))

Zack Barresse 

1.) I updated the source data sheet to include two hierarchical columns

2.) I attempted the pivot table method to group the source data (see sheet pivot)

I hope it is clearer now, and you can assist me further.

Thanks and best regards

@Zack Barresse

Please find attached with a few more columns.

pbolali I'm not entirely sure what you mean.

---

The input sheet can be modified to include all the relationships, please let me know if more columns are required.

---

Can you give specific details for this? I'd like to see what you mean by this.

---

The serial numbers (s/n) were actually on the source input sheet but I wanted it to restart from 1 to lastrow for each group.

---

Are you altering the data to post it here in an attempt to make it easier for us? If so, please do not. It ends up making for more work. Otherwise, I'd like to see how this field is incorporated into your data as well.

Each invoice number suggests the group it belongs to; the reason i provided the invoice key.

In practice, domestic crude is made up of two groups (direct sales and refinery supplies) thus invoiced as *dsdp* and *dom* as the case may be.  The sheet 'Invoice Keys' was to explain the hierarchy of groupings and these groupings were (manually) done by grouping similar invoices. 

This sounds like it's on the avenue of  what you are wanting and how we can help you get there. However, the structure on the sheet 'Invoice Keys' doesn't really help us as it's not defined at all. I can't understand what any of that means as it's just data on a sheet without organization or definition. If, however, that sheet is just an amalgamation of how the 'INVOICE NO.' field is defined/interpreted, we can ignore that altogether if you just define that field. Tell us what it means, how to parse it, and how it relates to your organization/hierarchy.

With all of this in mind, it honestly still looks like a PivotTable report to me. The key is going to be ensuring your source data is structured properly. Even if you have multiple defined Tables which are related, we can make it work. But we need all of the data in an organized structure. In your 'Expected Output' sheeet you have 3 overall levels of hierarchy, whereas previously we'd only had 1 defined (2 if you count the latest sub group request). This is what we must explore and define.

Zack Barresse 

The input sheet can be modified to include all the relationships, please let me know if more columns are required.

The serial numbers (s/n) were actually on the source input sheet but I wanted it to restart from 1 to lastrow for each group.

Each invoice number suggests the group it belongs to; the reason i provided the invoice key.

In practice, domestic crude is made up of two groups (direct sales and refinery supplies) thus invoiced as *dsdp* and *dom* as the case may be.  The sheet 'Invoice Keys' was to explain the hierarchy of groupings and these groupings were (manually) done by grouping similar invoices. 

I am willing to accept your advice on the preferred format of the source data sheet and/or the preferred solution; whether it is the pivot or code. I am actually learning, not an expert in excel yet. So your professional advice will be followed. 

Zack Barresse 

My apologies. I think I am the one not explaining my request right. I did provided answers to the questions you asked but I noticed the reply was removed (probably contained prohibited content).

I have added two additional sheets.

1.) Expected report if i do it manually (a very beautiful report) but it takes a lot of man hours

2.) Invoice keys (since we are grouping by similar invoice numbers)

I could see that both the earlier grouping and the most recent groupings work very well; the additional request was to have a group of groups. Please find attached notes that can assist in the final grouping.

I believe we are close to the final output. Please help me out.

pbolali ok, I went back to the drawing board a little bit and changed some of the coding. I went down a rabbit hole with collections of collections and a few classes, then threw it all away because it was getting very bloated and I went for a much simpler approach. Also, this ended up being much faster than the previous code.

Code is below and sample file is attached. There is a new worksheet titled 'Sub Groups' with a Table on it titled 'tGroups'. In it, you would define the group (Remark) you want to search for and in the adjacent column you specify what the group name should be. It should be self-explanatory when you look at it. Any group/remark not found in this list will be listed on it's own.

Sub SplitInvoiceData2()

    Dim Groups As New Collection
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim DataTable As ListObject
    Dim TargetRange As Range
    Dim GroupIndex As Long
    Dim RowIndex As Long
    Dim RowSize As Long
    Dim TotalRow As Long
    Dim DataValues As Variant

    Const SourceTableName As String = "Table1"
    Const TotalsFormat As String = "#,##0.00"
    Const SubtotalHeader As String = "SUB TOTAL"
    Const Grandtotalheader As String = "GRAND TOTAL"
    Const BufferRows As Long = 1
    Const TitleRow As String = "MONTHLY LIFTING PROFILE FOR THE MONTH OF "

    Set SourceSheet = ThisWorkbook.Worksheets("Sheet1")
    Set TargetSheet = ThisWorkbook.Worksheets("VBA Output")
    Set DataTable = SourceSheet.ListObjects(SourceTableName)

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    DataValues = DataTable.Range.Value
    TargetSheet.Cells.Clear

    Set TargetRange = TargetSheet.Cells(1 + BufferRows, 2).Resize(UBound(DataValues, 1) - LBound(DataValues, 1) + 1, UBound(DataValues, 2) - LBound(DataValues, 2) + 1)
    TargetRange.Value = DataValues
    TargetRange.Sort Key1:=TargetRange.Columns(1), Order1:=xlAscending, Header:=xlYes
    TargetRange.Columns(1).Offset(0, -1).Formula = "=IFERROR(INDEX(tGroups[Group Header],MATCH(B2,tGroups[Remark],0))," & TargetRange.Cells(1, 1).Address(0, 0) & ")&"" GROUP"""
    TargetRange.Columns(1).Offset(0, -1).Value = TargetRange.Columns(1).Offset(0, -1).Value
    TargetRange.Columns(1).Delete xlToLeft
    
    Set TargetRange = TargetRange.Columns(1).Offset(0, -1).Resize(, TargetRange.Columns.Count + 1)
    TargetRange.Sort Key1:=TargetRange.Columns(1), Order1:=xlAscending, Header:=xlYes

    DataTable.DataBodyRange.Copy
    TargetRange.PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
    TargetRange.WrapText = False
    TargetRange.Font.Size = 8
    TargetRange.Interior.ColorIndex = xlAutomatic
    DataValues = Empty
    DataValues = TargetRange.Value
    
    For GroupIndex = LBound(DataValues, 1) To UBound(DataValues, 1)
        On Error Resume Next
        Groups.Add DataValues(GroupIndex, 1), DataValues(GroupIndex, 1)
        On Error GoTo 0
    Next GroupIndex
    
    For RowIndex = UBound(DataValues, 1) To LBound(DataValues, 1) + 1 Step -1
        
        If DataValues(RowIndex, 1) <> DataValues(RowIndex - 1, 1) Then
        
            If TotalRow = 0 Then
                TotalRow = RowIndex
                RowSize = 1
            Else
                RowSize = TotalRow + 1
                TotalRow = TotalRow + RowIndex
            End If
            
            TargetRange.Rows(RowIndex).Resize(3 + BufferRows).Insert
            TargetRange.Rows(RowIndex + BufferRows + 1).Cells(1, 2).Value = TargetRange.Rows(RowIndex + BufferRows + 3).Cells(1, 1).Value
            TargetRange.Rows(RowIndex + BufferRows + 2).Cells(1, 2).Resize(1, 15).Value = TargetRange.Cells(1, 2).Resize(1, 15).Value
            TargetSheet.Rows(RowIndex + BufferRows + 2).Cells(1, 2).Resize(1, 15).WrapText = False
            TargetSheet.Rows(RowIndex + BufferRows + 2).Cells(1, 2).Resize(1, 15).Interior.ColorIndex = xlAutomatic
            TargetRange.Rows(RowIndex + BufferRows + 1).Cells(1, 2).Font.Bold = True
            TargetRange.Rows(RowIndex + BufferRows + 1).Cells(1, 2).Font.Size = 12
            TargetRange.Rows(RowIndex + BufferRows + 1).Cells(1, 2).Interior.ColorIndex = 43
            TargetRange.Rows(RowIndex + BufferRows + 1).Cells(1, 2).BorderAround Weight:=xlThick

            With TargetRange.Cells(TotalRow + BufferRows + 4, 1).Resize(1, 16)
                .Interior.ColorIndex = 44
                .Cells(1, 2).Value = SubtotalHeader
                .Cells(1, 10).Resize(1, 7).FormulaR1C1 = "=SUM(R[-" & .Cells(1, 1).Row - (RowIndex + BufferRows + 4) & "]C:R[-1]C)"
                .Cells(1, 11).Value = ""
                .Cells(1, 13).Value = ""
                .Cells(1, 10).Resize(1, 7).NumberFormat = TotalsFormat
                .Borders.LineStyle = xlDouble
                .Font.Bold = True
            End With
            
            TotalRow = 0

        Else
            TotalRow = TotalRow + 1
        End If

    Next RowIndex
    
    TargetSheet.Columns(1).Delete
    
    TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Offset(2, 0).Value = Grandtotalheader
    TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Font.Bold = True
    TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Font.Size = 12
    
    With TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Offset(0, 8).Resize(1, 7)
        .Formula = "=IF(LEN(R[-" & BufferRows + 1 & "]C)=0,"""",SUMIF(R" & BufferRows + 5 & "C1:R[-" & BufferRows + 1 & "]C1,""" & SubtotalHeader & """,R" & BufferRows + 5 & "C:R[-" & BufferRows + 1 & "]C))"
        .NumberFormat = TotalsFormat
        .Font.Size = 12
        .Font.Bold = True
    End With
    
    TargetSheet.Rows(1).Resize(BufferRows + 1).Delete
    TargetSheet.Cells.EntireColumn.AutoFit
    
    TargetSheet.Range("A1").Value = TitleRow & UCase(Sheet1.Range("C9").Value2) & " " & Sheet1.Range("D9")
    TargetSheet.Range("A1").Font.Size = 18
    TargetSheet.Range("A1").Font.Bold = True
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

I think I remembered all of your requirements. Please let me know if I didn't.

Zack Barresse 

I agree the sub groups be on separate sheets as per attached, first sheet contains the notes to each report

Zack Barresse 

I have implemented you code with a little bit formatting and its looking pretty good as per attached.

Additional requirement please

1.) Add serial numbers to each group

2.) A further grouping of sub groups; (nested groups)

eg.  DPR ( DPR Royalty + DPR-RA)   -----------Group 1

       FIRS (FIRS PPT + FIRS DSDP-EX + FIRS DSDP) -----------Group 2

       GAS (NGCL + NGL + FEEDSTOCK) ------------------Group 3

      NPDC (NPDC + NPDC-DPR +NPDC-FIRS +NPDC-G&VC) ------------ Group 4

     Groups without combinations would remain as they are.

     Any similar remark item forms a group of the already created groups

While I ask for additional support, I appreciate the quantum of work, effort and time already put in to assist me. I am probably requesting for this additional  improvements to perfect the automation.

Thank you for your help.

See the (your) code below a little modification;

Option Explicit


Sub SplitInvoiceData()
    
    Dim Remarks As New Collection
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim Table As ListObject
    Dim Column As Long
    Dim Row As Long
    Dim Index As Long
    Dim NewRow As Long
    Dim RemarkIndex As Long
    Dim Remark As Variant
    Dim Output As Variant
    
    Const SourceTableName As String = "Table1"
    Const TotalsFormat As String = "#,##0.00"
    Const SubtotalHeader As String = "SUB TOTAL"
    Const Grandtotalheader As String = "GRAND TOTAL"
    Const BufferRows As Long = 1
    Const TitleRow As String = "MONTHLY LIFTING PROFILE FOR THE MONTH OF "
    
    Set SourceSheet = ThisWorkbook.Worksheets("Sheet1")
    Set TargetSheet = ThisWorkbook.Worksheets("VBA Output")
    Set Table = SourceSheet.ListObjects(SourceTableName)
    
    
    
    For RemarkIndex = 1 To Table.ListRows.Count
        On Error Resume Next
        Remarks.Add Table.ListRows(RemarkIndex).Range(1, 1), Table.ListRows(RemarkIndex).Range(1, 1)
        On Error GoTo 0
    Next RemarkIndex
    
    If Remarks.Count = 0 Then
        MsgBox "No criteria found"
        Exit Sub
    End If
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    TargetSheet.Cells.Clear
    
    For Each Remark In Remarks
        
        Row = 0
        
        For Index = 1 To Table.ListRows.Count
            If Table.ListRows(Index).Range(1, 1) = Remark Then
                Row = Row + 1
                If IsEmpty(Output) Then
                    ReDim Output(1 To 15, 1 To Row)
                Else
                    ReDim Preserve Output(1 To 15, 1 To Row)
                End If
                For Column = 1 To 15
                    Output(Column, Row) = Table.ListRows(Index).Range(1, Column + 1).Value
                Next Column
            End If
        Next Index
        
        NewRow = TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Row + BufferRows + 1
        
        'Remark
        TargetSheet.Cells(NewRow, 1).Value = Remark & " ACCOUNT"
        TargetSheet.Cells(NewRow, 1).Font.Bold = True
        TargetSheet.Cells(NewRow, 1).Font.Size = 12
        TargetSheet.Cells(NewRow, 1).Interior.ColorIndex = 43
        TargetSheet.Cells(NewRow, 1).BorderAround Weight:=xlThick
        
        
        'Header
        TargetSheet.Cells(NewRow + 1, 1).Resize(1, 15).Value = Table.HeaderRowRange(1, 2).Resize(1, 15).Value
        Table.HeaderRowRange(1, 2).Resize(1, 15).Copy
        TargetSheet.Cells(NewRow + 1, 1).Resize(1, 15).PasteSpecial xlPasteFormats
        TargetSheet.Cells(NewRow + 1, 1).Resize(1, 15).WrapText = False
        TargetSheet.Cells(NewRow + 1, 1).Resize(1, 15).Interior.ColorIndex = xlAutomatic
        
        'Data
        TargetSheet.Cells(NewRow + 2, 1).Resize(Row, 15).Value = Application.Transpose(Output)
        Table.ListRows(1).Range(1, 2).Resize(1, 15).Copy
        TargetSheet.Cells(NewRow + 2, 1).Resize(Row, 15).PasteSpecial xlPasteFormats
        TargetSheet.Cells(NewRow + 2, 1).Resize(Row, 15).WrapText = False
        TargetSheet.Cells(NewRow + 2, 1).Resize(Row, 15).Font.Size = 8
        TargetSheet.Cells(NewRow + 2, 1).Resize(Row, 15).Interior.ColorIndex = xlAutomatic
        
        'Total formulas
        With TargetSheet.Cells(NewRow + Row + 2, 1).Resize(1, 15)
            .Interior.ColorIndex = 44
            .Cells(1, 1).Value = SubtotalHeader
            .Cells(1, 9).Resize(1, 7).FormulaR1C1 = "=SUM(R[-" & Row & "]C:R[-1]C)"
            .Cells(1, 10).Value = ""
            .Cells(1, 13).Value = ""
            .Cells(1, 9).Resize(1, 7).NumberFormat = TotalsFormat
            .Borders.LineStyle = xlDouble
            .Font.Bold = True
        End With
       
        Application.CutCopyMode = False
        
    Next Remark
    
    'Grand totals
    TargetSheet.Cells(NewRow + Row + 2 + BufferRows, 1).Value = Grandtotalheader
    TargetSheet.Cells(NewRow + Row + 2 + BufferRows, 9).Resize(1, 7).FormulaR1C1 = "=SUMIF(R" & BufferRows + 3 & "C1:R[-" & BufferRows + 1 & "]C1,""" & SubtotalHeader & """,R" & BufferRows + 3 & "C:R[-" & BufferRows + 1 & "]C)"
    TargetSheet.Cells(NewRow + Row + 2 + BufferRows, 10).Value = ""
    TargetSheet.Cells(NewRow + Row + 2 + BufferRows, 13).Value = ""
    TargetSheet.Cells(NewRow + Row + 2 + BufferRows, 9).Resize(1, 7).NumberFormat = TotalsFormat
    TargetSheet.Rows(NewRow + Row + 2 + BufferRows).Font.Size = 12
    TargetSheet.Rows(NewRow + Row + 2 + BufferRows).Font.Bold = True
    TargetSheet.Cells(NewRow + Row + 2 + BufferRows, 1).Resize(1, 15).Borders.LineStyle = xlDouble
    TargetSheet.Cells(NewRow + Row + 2 + BufferRows, 1).Resize(1, 15).Interior.ColorIndex = 43
    
    
        With Sheet5.UsedRange
         .Borders(xlEdgeLeft).LineStyle = xlContinuous
         .Borders(xlEdgeRight).LineStyle = xlContinuous
         .Borders(xlEdgeBottom).LineStyle = xlContinuous
         .Borders(xlEdgeTop).LineStyle = xlContinuous
        End With
        

    
    TargetSheet.Cells.EntireColumn.AutoFit
    
    Sheet5.Range("A1").Value = TitleRow & UCase(Sheet1.Range("C9").Value2) & " " & Sheet1.Range("D9")
    Sheet5.Range("A1").Font.Size = 18
    Sheet5.Range("A1").Font.Bold = True
    
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub