بارك الله فيك استاذ سليم وفى جهودكم العظيمة ودائما وابداً محاولاتك الممتازة فى مساعدة كل من يحتاج الى المساعدة .... ما اقصده كلما انتهى نصف شهر معين وبدأ بعده تشغيلات شهر جديد او النصف الأخر من نفس الشهر فلابد من وضع صف ايضاً للإجمالى .. وهذا ما توضحه الصورة أكثر .... فأريد ايضاً عند الضغط لتنفيذ الكود يتم وضع كل صفوف الإجمالى المطلوبة اى الصفوف الملونة باللون الأزرق لأن الكود لا ينفذ على هذه الأوضاع , حتى وان لم تنتهى تشغيلات النصف الأول يوم 15 من الشهر او حتى لم تنتهى التشغيلات عند اخر يوم بالشهر سواء كان 28 , 29 ,30,31
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("A4:Q" & 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("A3:T" & New_ro).Sort key1:=sh.Range("A3"), Header:=xlYes
End Sub
'+++++++++++++++++++++++++++
Sub Insert_rows()
Set sh = ActiveSheet
'//////////////////////////////////
If sh.Range("A3") = "Date" _
And sh.Range("B3") = "Hurghada" _
And sh.Range("A2") = "" Then
Else
MsgBox "YOU HAVE DIFFERENT STRUCTURE OF SHEET" & Chr(10) & _
"MAKE THE SAME STRUCTURE OF THE SHEET :" & """ Limousin Agent"""
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("a4").AutoFilter
End If
New_ro = sh.Cells(Rows.Count, 1).End(3).Row
t = 4
For I = 4 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(, 17).Interior.ColorIndex = 6
sh.Cells(I + 1, 2).Resize(, 16).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(, 17).Interior.ColorIndex = 6
sh.Cells(New_ro, 2).Resize(, 16).Formula = _
"=SUM(B" & t & ":B" & New_ro - 1 & ")"
sh.Range("A4:Q" & New_ro).Value = _
sh.Range("A4:Q" & New_ro).Value
clear_last
'++++++++++++++++++++++++++++++++
Dim tt%
tt = Application.CountA(ActiveSheet.Range("a4:a500")) + 3
If ActiveSheet.Cells(tt, 1) = TOT And _
Application.Sum(ActiveSheet.Cells(tt, 2).Resize(, 16)) = 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 = 4 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("A4:Q" & 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
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
[1]
تعديل كود اضافة صف للإجمالى مرتين خلال نفس الشهر-للأستاذ ســلــيم حــاصــبيا
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
