• 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.

Set posting code to add a row for total after day 15 and after the end of each month

Hany ali

Active Member
hello my dear,
i want your help in this Code ..
How to put this Yellow Row As Total After day 15 and last day in Every month ?
After Transfer from Main Sheet to Every Sheets
for example in July Month , i want to add yellow Row after to make transfer from main sheet to another sheets in after 15/07/2020 and another one after 31/07/2020
thanks alot
Code:
Sub Test()
    Dim x, y, ws As Worksheet, sh As Worksheet, rng As Range, r As Long, m As Long
    Dim z As Long
    UseSpeedyCode True
        Set ws = ThisWorkbook.Worksheets("Main")
        z = ws.Cells(Rows.Count, 1).End(xlUp).Row
        For r = 3 To z
            If Evaluate("ISREF('" & ws.Cells(r, 3).Value & "'!A1)") Then
                 Set sh = ThisWorkbook.Worksheets(ws.Cells(r, 3).Value)
                 m = sh.Cells(Rows.Count, 18).End(xlUp).Row + 1
                 c = WorksheetFunction.CountIfs(sh.Range("a3:a" & m), _
                 ws.Cells(r, 1), sh.Range("r3:r" & m), ws.Cells(r, 2))
                 If c > 0 Then GoTo 1
                 sh.Cells(m, 1).Value = ws.Cells(r, 1).Value
                 sh.Cells(m, 18).Value = ws.Cells(r, 2).Value
                 sh.Cells(m, 19).Value = WorksheetFunction.SumIfs( _
                      ws.Range("g3:g" & z), ws.Range("a3:a" & z) _
                      , sh.Cells(m, 1).Value, ws.Range("b3:b" & z), _
                      sh.Cells(m, 18).Value, ws.Range("c3:c" & z), sh.Name)
                 sh.Cells(m, 20).Value = WorksheetFunction.SumIfs( _
                      ws.Range("h3:h" & z), ws.Range("a3:a" & z) _
                      , sh.Cells(m, 1).Value, ws.Range("b3:b" & z), _
                      sh.Cells(m, 18).Value, ws.Range("c3:c" & z), sh.Name)
                For x = 3 To 15 Step 4
                    For y = x - 1 To x + 2
                        sh.Cells(m, y).Value = WorksheetFunction.SumIfs( _
                             ws.Range("d3:d" & z), ws.Range("a3:a" & z), _
                             sh.Cells(m, 1).Value, ws.Range("b3:b" & z), _
                             sh.Cells(m, 18).Value, ws.Range("c3:c" & z), _
                             sh.Name, ws.Range("e3:e" & z), sh.Cells(1, x).Value, _
                             ws.Range("f3:f" & z), sh.Cells(2, y).Value)
                    Next
                Next
            End If
1
        Next r
    UseSpeedyCode False
      MsgBox "Done...", 64
End Sub
Public Function UseSpeedyCode(goFast As Boolean)
    Dim calc As Long
    With Application
        .ScreenUpdating = Not goFast
        .EnableEvents = Not goFast
        If goFast Then
            calc = .Calculation
                 .Calculation = xlCalculationManual
        Else
            .Calculation = calc
        End If
    End With
End Function
Sub Nor()
For x = 3 To 15 Step 4
For z = x - 1 To x + 2
MsgBox Cells(1, x)
MsgBox Cells(2, z)
Next
Next
End Sub
 

Attachments

  • example.png
    example.png
    31.2 KB · Views: 15
  • TransportatioCompanies.xlsm
    260.1 KB · Views: 12
Hany ali
Hint:
If You do not get answers, then You should give new information.
Any eg 'Up please' ... do it include something new?


Few basic questions:
'Limousine Agent' has three lines data,
how to be sure that none lines are missing eg from 04-Jul-2020?
You asked to add after that 'total'.
As well as, if there are none new lines with in ~two weeks, do then need to add 'total'?
Do that 'total' include all data or only those ~two weeks data?
When do that 'total' should add? ( I won't modify others code. )
 
thanks alot mr. Vletm For Your Replay
*of course I will be sure no data missing,because this Code work as Well to Moving Data from Main Page to another Sheets.
I want to add line as total after make transfer data from sheet"Main" to all file Sheets ,in middle of the Month ..I mean in 15 from every month and add elso in the last day in every month some month 28 ,29,30,31
Do that 'total' include all data or only those ~two weeks data?
yes Total just for Two Weeks Data Only

thank you again you are very kind
 
Hany ali
Seems You skipped three my questions:
1) How Your code take care, if You have to ADD today there 04-Jul-2020 data? Notice, that there is already that Your 'total'.
2) If there are none new lines with in ~two weeks, do then need to add 'total'?
3) When do that 'total' should add? ( I won't modify others code. )
 
thanks my Dear
1)if I have Even just 2 lines from first of the month till 15 in the month ,i want to add line for the Total
In short, I want to add the total row only twice during the operations that took place in the same month
2)of Course Yes , I Need to add "Total " in this Case
3)and Should To add Total ,As you Know every two Month ....After half a month and again after the end of the same month, the total is calculated from the 16th of the month to the end of the same month.
 
Hany ali
As written about one week ago:
Hint:
If You do not get answers, then You should give new information.
Any eg 'Up please' ... do it include something new?
 
thanks mr.
vletm

in screen what i want to put two lines in the same Month for total ... for example ,first one from start to half month from 01/07 till 15/07
and another line from 16/07 till 31/07/2020
 

Attachments

  • 1.png
    1.png
    60.8 KB · Views: 3
  • TransportatioCompanies.xlsm
    263.3 KB · Views: 3
Hany ali
eg if some one asks, how many fingers do You have?
Your way, it could be okay to answer like ... 'I ate an apple'.
... but not for me.
 
Hany ali
As You see in Your Photo ... which I could not see ...
1) I had tested only with Your original massive data
2) total ranges were: 1..15 & 16 .. end of month
3) Your of Course Yes , I Need to add "Total " in this Case
and so on...
 
Hany ali
Did You even try to read my previous reply?
1) If Your file has only those few lines data, then You should do that manually.
2) You skipped or remember?
3) as above #2
I have my file here.
 
Sorry mr.Vletm
few line Just for Test to saw the Result for Your Code , but in Basic I Have alot of Data for every Companies ...of course I Can't to make Manually
Where many mistakes will be made
may be last work Day for some Company is 25/07 and elso last day for first part may be in 10/07
 
of course i know that
I think this Photo and the file to be all the Questions and the Answer is Clear & what i want exactly
 

Attachments

  • TransportatioCompanies1.xlsm
    278.2 KB · Views: 7
  • 2.png
    2.png
    85 KB · Views: 4
Okay ...
I quickly checked Your ... photo:
You need to have those double lines with Z-column marks too.
Why so many rules has changed? Many things would be done, if could get exact clear rules.
Should I have time to continue digging ... and be ready ... what would next time change?
Keep on thinking ...
 
I didn't change any Rules ,that which I explain from Starting
and i did't need any thing in Z-column ,that Just to explain for You the Differant between when I Run Your Code and the Correct Way By Manuel
 
How can I amend this code to suit the manual method as in the picture when adding the total row?
Code:
Private Sub Do_It()
    With Application
        cm = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    With ActiveSheet
        a_max = .Cells(.Rows.Count, "A").End(xlUp).Row
        For a = a_max To 3 Step -1
            If .Cells(a, "A") = "Total" Then
                With .Range("A" & a & ":T" & a)
                    .ClearContents
                    .Interior.ColorIndex = xlNone
                    .Font.ColorIndex = 1
                End With
            End If
        Next a
        With .Sort
            .SortFields.Clear
'            .SortFields.Add2 Key:=Range("A3:A" & a_max), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range("A2:T" & a_max)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        d_min = WorksheetFunction.Min(.Range("A3:A" & a_max))
        d_max = Date
        dd = True
        a = 2
        For d = d_min To d_max
            If dd Then
                d1 = CLng(DateSerial(Year(d), Month(d), 1))
                d2 = CLng(DateSerial(Year(d), Month(d), 16))
            Else
                d1 = CLng(DateSerial(Year(d), Month(d), 16))
                d2 = CLng(DateSerial(Year(d), Month(d) + 1, 1))
            End If
            If d1 <= d_max Then
                Do
                    a = a + 1
                Loop Until .Cells(a + 1, "A") >= d2 Or .Cells(a, "A") = Empty
                a_max = a_max + 1
                .Rows(a & ":" & a).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                If a = 3 Then
                    .Range("A4:T4").Copy
                    .Range("A3").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                End If
                a3a = "A3:A" & a_max
                dd = Not dd
                .Cells(a, "A") = "Total"
                .Range("A" & a & ":R" & a).Interior.ColorIndex = 6
                With .Range("S" & a & ":T" & a)
                    .Interior.ColorIndex = 11
                    .Font.ColorIndex = 2
                End With
                For x = 2 To 20
                    s = WorksheetFunction.SumIfs(.Range(.Cells(3, x), .Cells(a_max, x)), .Range(a3a), ">=" & d1, .Range(a3a), "<" & d2)
                    .Cells(a, x) = s
                    If x = 17 Then x = x + 1
                Next x
            End If
            d = d2
        Next d
        .Range("AA1:AA2").Activate
    End With
    With Application
        .Calculation = cm
        .ScreenUpdating = True
    End With
End Sub
 

Attachments

  • 3.png
    3.png
    128.3 KB · Views: 5
Back
Top