Hello my Dear
What do I mean? Whenever a certain half of a month ends and starts after a new month or the other half of the same month, a row must also be placed for the total..and this is what the picture shows more ... so I also want when pressing to execute the code all the rows of the required total, i.e. the colored rows, are placed In blue color because the code does not apply to these situations, even if the operations of the first half did not end on the 15th of the month or until the operations did not end on the last day of the month, whether it was 28, 29, 30, 31
What do I mean? Whenever a certain half of a month ends and starts after a new month or the other half of the same month, a row must also be placed for the total..and this is what the picture shows more ... so I also want when pressing to execute the code all the rows of the required total, i.e. the colored rows, are placed In blue color because the code does not apply to these situations, even if the operations of the first half did not end on the 15th of the month or until the operations did not end on the last day of the month, whether it was 28, 29, 30, 31
Code:
Option Explicit
'+++++++++++++++++++++++++++++++++
Dim sh As Worksheet
Dim Max_ro%, New_ro%, I%, Mth, E_Mth
Dim rg As Range, del_rg As Range
Dim Last_date
Dim my_day
Const TOT = "Total"
Const dy = 15
'"""""""""""""""""""""""""""""""""""""
Sub get_total()
Set sh = ActiveSheet
Max_ro = sh.Cells(Rows.Count, 1).End(3).Row
sh.Range("A3:Y" & Max_ro).Interior.ColorIndex = xlNone
For I = Max_ro To 4 Step -1
If Not IsDate(sh.Cells(I, 1)) Then
sh.Cells(I, 1).EntireRow.Delete
End If
Next
End Sub
'+++++++++++++++++++++++++++
Sub Sort_data()
get_total
New_ro = sh.Cells(Rows.Count, 1).End(3).Row
sh.Range("A2:Y" & New_ro).Sort key1:=sh.Range("A2"), Header:=xlYes
End Sub
'+++++++++++++++++++++++++++
Sub Insert_rows()
Set sh = ActiveSheet
'//////////////////////////////////
If sh.Range("A2") = "Date" _
And sh.Range("B2") = "Hurghada" _
And sh.Range("b1") = "" Then
Else
MsgBox "YOU HAVE DIFFERENT STRUCTURE OF SHEET" & Chr(10) & _
"MAKE THE SAME STRUCTURE OF THE SHEET :" & """ Sempre Travel"""
Exit Sub
End If
'//////////////////////////////
Dim x As Boolean, y As Boolean, z As Boolean
Dim t%, k, A
Sort_data
If sh.AutoFilterMode Then
sh.Range("a3").AutoFilter
End If
New_ro = sh.Cells(Rows.Count, 1).End(3).Row
t = 3
For I = 3 To New_ro + 1000
If sh.Cells(I, 1) = vbNullString Then Exit For
If IsDate(sh.Cells(I, 1)) Then
Mth = Month(sh.Cells(I, 1))
Last_date = DateSerial(Year(sh.Cells(I, 1)), Mth + 1, 0)
E_Mth = Month(Last_date)
my_day = Day(Last_date)
x = Mth = E_Mth
y = Day(sh.Cells(I, 1)) = dy Or Day(sh.Cells(I, 1)) = my_day
z = sh.Cells(I, 1) <> sh.Cells(I + 1, 1)
If x * y * z = -1 Then
sh.Cells(I + 1, 1).Select
sh.Cells(I + 1, 1).EntireRow.Insert , xlDown
sh.Cells(I + 1, 1) = TOT
sh.Cells(I + 1, 1).Resize(, 25).Interior.ColorIndex = 6
sh.Cells(I + 1, 2).Resize(, 24).Formula = _
"=SUM(B" & t & ":B" & I & ")"
t = I + 2: I = I + 1: k = k + 1: New_ro = New_ro + 1
End If 'x * y * z
End If 'isdate
Next
New_ro = sh.Cells(Rows.Count, 1).End(3).Row + 1
sh.Cells(New_ro, 1) = TOT
sh.Cells(New_ro, 1).Resize(, 25).Interior.ColorIndex = 6
sh.Cells(New_ro, 2).Resize(, 24).Formula = _
"=SUM(B" & t & ":B" & New_ro - 1 & ")"
sh.Range("A3:Y" & New_ro).Value = _
sh.Range("A3:Y" & New_ro).Value
clear_last
'+++++++++++++++++++++++++++++++++++
Dim tt%
tt = Application.CountA(ActiveSheet.Range("a3:a500")) + 3
If ActiveSheet.Cells(tt, 1) = TOT And _
Application.Sum(ActiveSheet.Cells(tt, 2).Resize(, 24)) = 0 Then
ActiveSheet.Cells(tt, 2).EntireRow.Delete
End If
A = Application.CountIf(sh.Range("A:A"), TOT)
MsgBox "I Enter " & A & " " & _
IIf(A = 1, TOT, "Recordes") & " For you " & Chr(10) & _
" I hope you say thank you : " & """SALIM"""
End Sub
'+++++++++++++++++++++++++++++++++++
Sub clear_last()
Dim m%, Ro%, XX%, d1, d2, kk%, cnt%
Dim dat1, m1
Set sh = ActiveSheet
m = sh.Cells(Rows.Count, 1).End(3).Row - 1
For XX = 3 To m
If sh.Cells(XX, 1) = TOT Then
Ro = sh.Cells(XX, 1).Row
End If
Next
For kk = Ro + 1 To m
m1 = Month(sh.Cells(kk, 1))
d1 = Day(sh.Cells(kk, 1))
d2 = Day(DateSerial(Year(sh.Cells(kk, 1)), m1 + 1, 0))
If d1 <> dy Or d1 <> d2 Then
cnt = cnt + 1
End If
Next
If cnt > 0 Then Cells(m + 1, 1).EntireRow.Delete
End Sub
'++++++++++++++++++++++++++++++++++++++
Sub CLEAR_TOTALS()
Dim k%, B%
Set sh = ActiveSheet
B = Application.CountIf(sh.Range("A:A"), TOT)
Max_ro = sh.Cells(Rows.Count, 1).End(3).Row
sh.Range("A3:y" & Max_ro).Interior.ColorIndex = xlNone
For I = Max_ro To 3 Step -1
If Not IsDate(sh.Cells(I, 1)) Then
sh.Cells(I, 1).EntireRow.Delete
k = k + 1
End If
Next
MsgBox "I Clear " & B & " " & _
IIf(B = 1, TOT, "Recordes") & " For you " & Chr(10) & _
" I hope you say thank you : " & """SALIM"""
End Sub