Data Transformation using VBA like subtotal

[Negi1984]

Hi All,

I have excel file where I have approx. 38 columns but in order to create report I need only below mentioned headers from that report (approx 15 columns ).

Logic :-
1) First remove all extra columns apart from below mentioned headers
2) Sort CPO column in ascending order and insert a new row below every new CPO number.
3) Now I want to type "Total " Below Site ID
4) then it should show total of invoice value below Invoice value column
5) Under ATI column it should show data in format like : (count of unique quantity) Site +quantity in %+ CPO +ATI
eg : we have CPO number 222 3 times and unique quantity under it are 0.5 & 0.1 , CPO number 222, ATI is 2 then output for this should be like below

1 Site 50% PO 222 ATI 2 2 Site 10% PO 222 ATI 2

6) Type whatever values mentioned in column for respective CPO for column :Line Item Text to include on invoice, "Billing milestone" , "Currency " , "VAT", "Customer ", Payment terms " in new row inserted as per point 2

Below is my raw data :-

Invoice and Tax date

Site ID

CPO

Sales Order number

WBS

Quantity

Unit Price

Invoice value

ATI number (Invoice output to customer)

Line Item Text to include on invoice

Billing milestone

Currency

VAT

Customer

Payment terms

9/26/2024​

a

11​

0.7​

4201.22​

1​

A

A

A

A

A

9/26/2024​

d

222​

0.5​

4201.22​

2​

A

A

A

A

A

9/26/2024​

f

222​

0.1​

519​

2​

A

A

A

A

A

9/26/2024​

b

11​

0.3​

679​

1​

A

A

A

A

A

9/26/2024​

e

222​

0.1​

705​

2​

A

A

A

A

A

Final Output needed

Invoice and Tax date

Site ID

CPO

Sales Order number

WBS

Quantity

Unit Price

Invoice value

ATI number (Invoice output to customer)

Line Item Text to include on invoice

Billing milestone

Currency

VAT

Customer

Payment terms

9/26/2024​

a

11​

0.7​

4201.22​

1​

A

A

A

A

A

9/26/2024​

b

11​

0.3​

679​

1​

A

A

A

A

A

Total

4880.22​

1 Site 70% PO 11 ATI 1 1 Site 30% PO 11 ATI 1

A

A

A

A

A

9/26/2024​

d

222​

0.5​

4201.22​

2​

A

A

A

A

A

9/26/2024​

e

222​

0.1​

705​

2​

A

A

A

A

A

9/26/2024​

f

222​

0.1​

519​

2​

A

A

A

A

A

Total

5425.22​

1 Site 50% PO 222 ATI 2 2 Site 10% PO 222 ATI 2

A

A

A

A

A

Please help me out how to perform this using VBA macro.

 

[Domenic]

The following code assumes that the workbook running the code contains the data. It also assumes that the data is contained on Sheet1 (change the sheet name accordingly). Note that if you run the code when the sheet has already been sorted and subtotalled, it will first remove the subtotals, then it will sort, and then it will subtotal.

Option Explicit

Sub Sort_and_Subtotal_Data()

    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim rowIndex As Long
    Dim dic As Object
    Dim cpo As String
    Dim ati As String
    
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'change the sheet name accordingly
    
    With ws
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set rng = .Range("A1", .Cells(lastRow, lastCol))
    End With
    
    If rng.Rows.Count = 1 Then
        MsgBox "No data available.", vbExclamation
        Exit Sub
    End If
    
    Application.DisplayAlerts = False
    With ws.Sort
        With .SortFields
            .Clear
            .Add2 key:=rng(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange rng
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.DisplayAlerts = True
    
    Application.DisplayAlerts = False
    rng.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(8), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    Application.DisplayAlerts = True
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    rowIndex = 2
    With ws
        cpo = .Cells(rowIndex, "C").Value
        ati = .Cells(rowIndex, "I").Value
        Do
            dic(.Cells(rowIndex, "F").Value) = dic(.Cells(rowIndex, "F").Value) + 1
            rowIndex = rowIndex + 1
            If Right$(.Cells(rowIndex, "C").Value, 5) = "Total" Then
                .Cells(rowIndex, "I").Value = getATISummary(cpo, ati, dic)
                rowIndex = rowIndex + 1
                cpo = .Cells(rowIndex, "C").Value
                ati = .Cells(rowIndex, "I").Value
                dic.RemoveAll
            End If
        Loop While Len(.Cells(rowIndex, "C")) > 0
    End With
    
    With ws.Columns("I")
        .AutoFit
        .WrapText = True
    End With
    
End Sub

Private Function getATISummary(ByVal cpo As String, ByVal ati As String, ByVal dic As Object) As String

    Dim atiSummary As String
    Dim key As Variant
    
    atiSummary = ""
    For Each key In dic.keys
        atiSummary = atiSummary & vbLf & dic(key) & " Site " & key * 100 & "% PO " & cpo & " ATI " & ati
    Next key
    
    atiSummary = Mid$(atiSummary, 2)
    
    getATISummary = atiSummary
    
End Function

Hope this helps!