• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA code to split sales report sheet to groups by invoice type to a new worksheet

P

pmxpo

New Member
Please remember to follow all forum rules: Cross-posting
I have a sales master data (with over 20 columns).
It contains the following:
S/N, Customer, Invoice date, Due date, vessel, producer, fiscal regime, quantity, price, sales value, date paid, amount paid, variance, remark, etc

1.) I need a macro to group this report by invoice type, sum each group, with the column header and group title for each group on same sheet.

2.) Copy 1 or more groups to form a another report on separate sheets

3.) Write the summary (like a pivot table) for some of the column headers. Eg, Fiscal regime, sum by each producer with columns quantity, sales value and receipts

4.) Group 1 or more of the summaries to form another report on separate sheets.

Not to write too much, I am able to provide more clarity when we start.

Thanks for your kind assistance.
 
What have you accomplished on your own toward this project ?

Can you post a sample copy of your workbook for review ? Along with sample reports you have outlined ?

Aside from that, it sounds like you are asking for a complete project to be written which is better suited for
posting in a commercial request forum ?
 
Logit said:
What have you accomplished on your own toward this project ?

Can you post a sample copy of your workbook for review ? Along with sample reports you have outlined ?

Aside from that, it sounds like you are asking for a complete project to be written which is better suited for
posting in a commercial request forum ?
Click to expand...

I have been able to do an advance filter which does one grouping; though not a very professional code (i am a beginner).
I need to combine more than one group (more than one criteria) as per attached. 1.) on same sheet. 2.) combine two or more to form other reports.
I understand, I need to take a step at a time, but I would appreciate a guide through it.

So far, i have been able to write the code below;
Code: 
Option Explicit

Sub App_A()
       
    ' Get the range
    Dim rg, ra As Range
    Dim i, j As Integer
    Dim lastRow As Long
    Dim bl, dm As String
    Dim dd As Long
    Dim sl, rpt As String
   
    sl = "SALES PROFILE  FOR THE MONTH OF "
    rpt = "REVENUE INTO ACCOUNT WITH JP THE BANK IN "
    bl = shdata.Range("C2")
    dd = shdata.Range("D2")
    dm = shdata.Range("E2")
   
   
    TurnOffFunctionality
   
    shappa.Range("A1").Value = "COMPANY"
    shappa.Range("A2").Value = sl & UCase(bl) & " " & dd & " AND EXPECTED"
    shappa.Range("A3").Value = rpt & UCase(dm) & " " & dd
    shappa.Range("B5").Value = UCase("crude oil export - ") & shdata.Range("AA5") & UCase(" account")
   
   
    Set rg = shdata.Range("A10").CurrentRegion

    ' Clear the filter in case one exists
    rg.AutoFilter
   
    Dim CriteriaRange As Range, CopyRange As Range
    Set CriteriaRange = shdata.Range("AA4:AA5")
    Set CopyRange = shappa.Range("A6:R6")
    ' Filter column 10 on the city
    rg.AdvancedFilter xlFilterCopy, CriteriaRange, CopyRange

    ' Clear the filter when finished
    rg.AutoFilter
   
    ' Activate the Report sheet
    shappa.Activate
   
   
     With shappa
        lastRow = shappa.Cells(Rows.Count, 1).End(xlUp).Row
   
        Set ra = shappa.Range("A7: R" & lastRow)
       
        For j = 7 To lastRow
            For i = 10 To 17
            Cells(lastRow + 1, i) = Cells(lastRow + 1, i) + Application.WorksheetFunction.Sum(Cells(j, i))
            Next i
        Next j

        ra.Font.Name = "Albertus Medium"
        ra.Font.Size = 16
        ra.Font.Bold = False
       
        Cells(lastRow + 1, 2) = "SUB-TOTAL"
       
        If Cells(lastRow + 1, 10) = 0 Then
            Cells(lastRow + 1, 11).Value2 = ""
        Else
            Cells(lastRow + 1, 11) = Cells(lastRow + 1, 12) / Cells(lastRow + 1, 10)
        End If
       
        Cells(lastRow + 1, 15) = ""
       
        Cells(lastRow + 1, 10).NumberFormat = "#,##0;-#,##0"
        Cells(lastRow + 1, 11).NumberFormat = "#,##0.0000;-#,##0.0000"
        Cells(lastRow + 1, 12).NumberFormat = "#,##0.00"
        Cells(lastRow + 1, 13).NumberFormat = "#,##0.00"
        Cells(lastRow + 1, 14).NumberFormat = "#,##0.00"
        Cells(lastRow + 1, 16).NumberFormat = "#,##0.00"
        Cells(lastRow + 1, 17).NumberFormat = "#,##0.00"
       
       
        Rows(lastRow + 1).Font.Name = "Albertus Medium"
        Rows(lastRow + 1).Font.Size = 16
        Rows(lastRow + 1).Font.Bold = True
       
        With Selection.Font
        .Color = vbBlack
        .Bold = False
        End With
        With Selection.Interior
        .Color = xlNone
        End With
        With Selection.Borders(xlEdgeLeft)
                .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
                .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .Weight = xlThin
        End With
       
        Dim llRow, llCol, colNum, Column  As Long
        Dim Rng As Range
       

        .Range("B1:R" & lastRow).Columns.AutoFit
        .Range("A1:R" & lastRow).Rows.AutoFit
        '.Range(.cells(lr).Interior.Color = rgbLightBlue
                             
            llRow = .Cells(.Rows.Count, 2).End(xlUp).Row
            llCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
           
            Set Rng = shappa.Range(Cells(llRow, 18), Cells(llRow, llCol))
           
              
            Rng.Interior.Color = rgbLightBlue
            Rng.BorderAround Weight:=xlThick
       
   End With
    AppA_1.Range("a1:s200").ClearContents
   
    shappa.Activate
    shappa.Range("A1").Select
   
    shappa.Range("A1:R" & lastRow + 1).Copy Destination:=AppA_1.Range("A1")
   
    'shappa.Range("A1:R" & lastRow + 1).Copy
    'AppA_1.Range("a1").PasteSpecial Paste:=xlPasteFormats
       
    AppA_1.Range("B1:R" & lastRow).Columns.AutoFit
    AppA_1.Range("A1:R" & lastRow).Rows.AutoFit
   
        'AppA_1.Range(Cells(Rows.Count, "A").End(xlUp).Offset(3), Cells(Rows.Count, "A")).EntireRow.Clear

        AppA_1.Activate
        AppA_1.Range("A1").Select
   
   
   TurnOnFunctionality

End Sub
 

Attachments

  • SALES REPORT TEST1.xlsm
    133 KB · Views: 7
Last edited by a moderator:
Please see attached the expected final report. The reason, i need a guide on how to go through this tough project...
 

Attachments

  • Copy of DEMO Report.xlsx
    215 KB · Views: 8
Please find attached a sample with a code I have attempted...
Sheet1 contains master data, sheet2 contains the filtered data copied from sheet1.

>>>> 2nd time -- use code - tags <<<<
Code: 
Option Explicit
Sub Filter_Invoices()
Dim c As Range, i, z, lr As Long
Dim lastrow As Long, nextrow As Long

Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'Application.ScreenUpdating = False

' test for entries in the input range - exit sub if no entries
If WorksheetFunction.CountA(Sheet1.Range("A1:A10")) < 1 Then Exit Sub

'prepare output sheet to receive new filter results
Sheet2.Cells.Clear

With Sheet1

lastrow = .Cells(Rows.Count, "A").End(xlUp).Row

' count number of entries in the input cells
i = WorksheetFunction.CountA(.Range("A1:A9"))

'turn off any previous filters
If .AutoFilterMode = True Then .AutoFilterMode = False

'loop through input cells and filter and copy results
For Each c In .Range("A1:A" & i)
nextrow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row + 3
.Range("A10:A" & lastrow).AutoFilter field:=1, Criteria1:="=" & c.Value
.Range("A10:p" & lastrow).SpecialCells(xlCellTypeVisible).Copy Sheet2.Range("A" & nextrow)

With Worksheets("Sheet2")
lr = .Cells(.Rows.Count, 1).End(xlUp).Row

'.Cells(lr + 1, 1).Value = "Total"
'lr = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lr + 1, 1).Value = "Total"
.Cells(lr + 1, 10).Resize(, 8).FormulaR1C1 = "=SUM(R3C:R[-1]C)"

With .Range(.Cells(lr + 1, 1), .Cells(lr + 1, 16))
.HorizontalAlignment = xlRight
.Font.Bold = True
.Interior.Color = rgbLightBlue
End With
'.Range("A & lastrow").CurrentRegion.Weight = xlThin

End With

Next c

'turn off filtering
.AutoFilterMode = False
End With

Sheet2.Activate
Sheet2.Range("A4").Select

Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.ScreenUpdating = True
'Application.ScreenUpdating = True
End Sub
 

Attachments

  • Automation progress 2020.xlsm
    25.8 KB · Views: 6
Last edited by a moderator:
pmxpo
Please, reread Your just reread Forum Rules.

Site Rules - New Users - Please Read

Hi all, Welcome to the Chandoo.org Forums. Posting Rules & Etiquette The Chandoo.org Forums is a collaborative and happy place to learn and expand your Excel knowledge. The Chandoo.org Forums consist of several Sub-Forums based on the type of question/area of Excel you are interested in...
chandoo.org
Seems that You'll remember something soon:
 
I checked and there was no code on the attached... it was a table added. What I requested wad a vba
 
You must log in or register to reply here.
Back
Top