عمل جداول أوتوماتيكا

خالد ابوعوف · يناير 23, 2019

حياكم الله

عندي ثلاث شيتات

الشيت الاول فيه البيع

الشيت الثاني مفصل حسب الاسم

الشيت الثالث : مفصل البيع حسب التاريخ

عمل الشيتات الثاني والثالث

اوتوماتيكا

جدول الشراء.xlsx

**سليم حاصبيا** · يناير 23, 2019

جرب هذا الماكرو

Option Explicit

Sub resume_facture()
Dim my_arr2(1 To 2)
my_arr2(1) = "مجموع مبلغ الشراء حسب التاريخ": my_arr2(2) = "التاريخ":
Dim i%, k%, m%: m = 2
Dim s#
Dim lr1%: lr1 = Achat.Cells(Rows.Count, 1).End(3).Row
Dim lr2%: lr2 = Detail.Cells(Rows.Count, 1).End(3).Row
Dim lr3%: lr3 = By_Date.Cells(Rows.Count, 1).End(3).Row
Dim laste_D%
Dim laste_B%


Detail.Range("A1:D" & lr2).ClearContents
By_Date.Range("a1:b" & lr3).ClearContents
Dim Fter_Rg As Range
Set Fter_Rg = Achat.Range("a1:d" & lr1)
Dim Col As Object
Set Col = CreateObject("system.collections.arraylist")
With Col
For i = 2 To lr1
 If Not .contains(Achat.Range("b" & i).Value) Then _
   .Add Achat.Range("b" & i).Value
   Next
End With
 For i = 0 To Col.Count - 1
 '-----------------------------
   laste_D = Detail.Cells(Rows.Count, 1).End(3).Row
   If laste_D% <> 1 Then laste_D% = laste_D% + 2
  '=========================
  Fter_Rg.AutoFilter 2, Col.Item(i)
  Fter_Rg.SpecialCells(12).Copy _
  Detail.Range("a" & laste_D%)
 Next
 Fter_Rg.AutoFilter
 Col.Clear
 '=========================
 By_Date.Cells(1, 1).Resize(, 2) = my_arr2
 For i = 2 To lr1
 If Not Col.contains(Achat.Range("d" & i).Value) Then _
   Col.Add Achat.Range("d" & i).Value
   Next
  '=========================
  
 For i = 0 To Col.Count - 1
  For k = 2 To Fter_Rg.Rows.Count
    If Achat.Range("D" & k) = Col.Item(i) Then
     By_Date.Range("b" & i + 2) = Col.Item(i)
     s = s + Achat.Range("C" & k)
     End If
   Next
    By_Date.Range("A" & i + 2) = s
    s = 0
   Next
 '===================
End Sub

الملف مرفق

_salimجدول الشراء.xlsm

**Ali Mohamed Ali** · يناير 23, 2019

بالتأكيد هذا يسمى ابداع

احسنت استاذى الكبير سليم عمل رائع بارك الله فيك وجعله فى ميزان حسناتك واكثر الله من امثالك وزادك الله من فضله

عبد القادر محمد مهدى · يناير 23, 2019

الان, سليم حاصبيا said:

جرب هذا الماكرو


Option Explicit

Sub resume_facture()
Dim my_arr2(1 To 2)
my_arr2(1) = "مجموع مبلغ الشراء حسب التاريخ": my_arr2(2) = "التاريخ":
Dim i%, k%, m%: m = 2
Dim s#
Dim lr1%: lr1 = Achat.Cells(Rows.Count, 1).End(3).Row
Dim lr2%: lr2 = Detail.Cells(Rows.Count, 1).End(3).Row
Dim lr3%: lr3 = By_Date.Cells(Rows.Count, 1).End(3).Row
Dim laste_D%
Dim laste_B%


Detail.Range("A1:D" & lr2).ClearContents
By_Date.Range("a1:b" & lr3).ClearContents
Dim Fter_Rg As Range
Set Fter_Rg = Achat.Range("a1:d" & lr1)
Dim Col As Object
Set Col = CreateObject("system.collections.arraylist")
With Col
For i = 2 To lr1
 If Not .contains(Achat.Range("b" & i).Value) Then _
   .Add Achat.Range("b" & i).Value
   Next
End With
 For i = 0 To Col.Count - 1
 '-----------------------------
   laste_D = Detail.Cells(Rows.Count, 1).End(3).Row
   If laste_D% <> 1 Then laste_D% = laste_D% + 2
  '=========================
  Fter_Rg.AutoFilter 2, Col.Item(i)
  Fter_Rg.SpecialCells(12).Copy _
  Detail.Range("a" & laste_D%)
 Next
 Fter_Rg.AutoFilter
 Col.Clear
 '=========================
 By_Date.Cells(1, 1).Resize(, 2) = my_arr2
 For i = 2 To lr1
 If Not Col.contains(Achat.Range("d" & i).Value) Then _
   Col.Add Achat.Range("d" & i).Value
   Next
  '=========================
  
 For i = 0 To Col.Count - 1
  For k = 2 To Fter_Rg.Rows.Count
    If Achat.Range("D" & k) = Col.Item(i) Then
     By_Date.Range("b" & i + 2) = Col.Item(i)
     s = s + Achat.Range("C" & k)
     End If
   Next
    By_Date.Range("A" & i + 2) = s
    s = 0
   Next
 '===================
End Sub

الملف مرفق

_salimجدول الشراء.xlsm

احسنت وابدعت استاذنا salim الله يبارك فى حضرتك

بعد اذنك اساذنا ممكن شرح الكود الرائع من ابدعاتك

شكرا لحضرتك

خالد ابوعوف · يناير 24, 2019

حياك الله الاستاذ المحترم سليم - مشكور - تفضلت علينا

ملاحظة :

1 - في الشيت الثاني - لم يقم بالجمع

2 - تم اضافة عمود واحد جديد - في شيت الاول Achat - وفقت والحمد لله من التعديل على الكود - ممكن التفضل والنظر على الملف المرفق الجديد لعمل التغييرات المطلوبة

ملاحظات مهمة - راجين الاهتمام بالموضوع

ولكم من الله تعالى الأجر - إنه لا يضيع أجر المحسنين

_salimجدول الشراء (1).xlsm

تم تعديل يناير 24, 2019 بواسطه خالد ابوعوف
اضافة وتعديل

armageddone18 · يناير 24, 2019

جرب هذا الملف وبأذن الله سيفي بالغرض ....

جدول الشراء.xlsx

تم تعديل يناير 24, 2019 بواسطه armageddone18

خالد ابوعوف · يناير 24, 2019

تسلم

اريد فقط التعديل على الكود

لأن الديباجة وسهولة التدقيق والمتابعة مع الزبائن مفيدة جدا

شاكرين تعاونكم معنا

**سليم حاصبيا** · يناير 24, 2019

تم معالجة الامر

الكود

Option Explicit

Sub resume_facture()
Dim my_arr2(1 To 2)
my_arr2(1) = "مجموع مبلغ الشراء حسب التاريخ": my_arr2(2) = "التاريخ":
Dim i%, k%, m%: m = 2
Dim s#
Dim lr1%: lr1 = Achat.Cells(Rows.Count, 1).End(3).Row
Dim lr2%: lr2 = Detail.Cells(Rows.Count, 1).End(3).Row
Dim lr3%: lr3 = By_Date.Cells(Rows.Count, 1).End(3).Row
Dim laste_e%
Dim laste_B%


Detail.Range("A1:e" & lr2).ClearContents
By_Date.Range("a1:b" & lr3).ClearContents
Dim Fter_Rg As Range
Set Fter_Rg = Achat.Range("a1:e" & lr1)
Dim Col As Object
Set Col = CreateObject("system.collections.arraylist")
With Col
For i = 2 To lr1
 If Not .contains(Achat.Range("b" & i).Value) Then _
   .Add Achat.Range("b" & i).Value
   Next
End With
 For i = 0 To Col.Count - 1
 '-----------------------------
   laste_e = Detail.Cells(Rows.Count, 1).End(3).Row
   If laste_e% <> 1 Then laste_e% = laste_e% + 2
  '=========================
  Fter_Rg.AutoFilter 2, Col.Item(i)
  Fter_Rg.SpecialCells(12).Copy _
  Detail.Range("a" & laste_e%)
 Next
 Fter_Rg.AutoFilter
 Col.Clear
 '=========================
 By_Date.Cells(1, 1).Resize(, 2) = my_arr2
 For i = 2 To lr1
 If Not Col.contains(Achat.Range("d" & i).Value) Then _
   Col.Add Achat.Range("d" & i).Value
   Next
  '=========================
  
 For i = 0 To Col.Count - 1
  By_Date.Range("b" & i + 2) = Col.Item(i)
  For k = 2 To Fter_Rg.Rows.Count
    If Achat.Range("D" & k) = Col.Item(i) Then
    
     s = s + Achat.Range("C" & k)
     End If
   Next
    By_Date.Range("A" & i + 2) = s
    s = 0
   Next
  Creat_formula
 '===================
End Sub
Rem+++++++++++++++++++++++++++++++++++++++++++++++++
Sub Creat_formula()
With Detail
Dim arr1(), arr2(), k%: k = 1
Dim t%: t = 1
Dim i%
Dim Ro%: Ro = .Cells(Rows.Count, 2).End(3).Row
For i = 2 To Ro + 1
 If .Cells(i, 2) = "" Then
  .Cells(i, 1) = "Sum"
   End If
  Next
.Range("F2:F" & Ro).Formula = "=IF(NOT(ISNUMBER(C2)),"""",SUM(C2,-E2))"
'==========================
For i = 1 To Ro + 1
 If .Cells(i, 1) = "رقم بطاقة السكن" Then
  ReDim Preserve arr1(1 To k): arr1(k) = (.Cells(i, 1).Row) + 1
  k = k + 1
   End If
  Next
For i = 1 To Ro + 1
 If .Cells(i, 1) = "Sum" Then
  ReDim Preserve arr2(1 To t): arr2(t) = (.Cells(i, 1).Row) - 1
  t = t + 1
   End If
  Next
'=========================
 For i = LBound(arr1) To UBound(arr1)
  With .Cells(arr2(i) + 1, 3)
    .Formula = "=SUM(C" & arr1(i) & ":C" & arr2(i) & ")"
    .Offset(, 2).Formula = "=SUM(E" & arr1(i) & ":E" & arr2(i) & ")"
    .Offset(, 3).Formula = "=SUM(F" & arr1(i) & ":F" & arr2(i) & ")"
  End With

 Next
 Erase arr1: Erase arr2
End With

End Sub

_Version _1 _salim.xlsm

خالد ابوعوف · يناير 24, 2019

حياك الله استاذ

تسلم

تسجيل الدخول

عمل جداول أوتوماتيكا

الردود الموصى بها

خالد ابوعوف

سليم حاصبيا

Ali Mohamed Ali

عبد القادر محمد مهدى

خالد ابوعوف

armageddone18

خالد ابوعوف

سليم حاصبيا

خالد ابوعوف

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information