اصلاح كود جمع وطرح قيم بيانات بين اوراق متعددة لنفس العمود

[عبدالفتاح في بي اكسيل]

السلام  عليكم 

الى خبراء  الاكسيل  احتاج  الى تعديل  الكود     حيث  الكود   لا يعمل  جيدا  بالنسبة  لعملية  الجمع  والطرح  في  العمود d  لاوراق  العمل 1و2و3و4و5   اما 6  فيظهر  النتيجة   

النتيجة الموجود  في الورقة 6  هي  المفترض  ان تكون  عند  الضغط   على زر  الماكرو  اكثر من مرة  يتم اظهار نتائج  خاظئة  بالاضافة انه  يقوم بتكرار البيانات  وهذا  ما لاا اريده   انا  هنا  اتحدث  عن مشكلة  الكود  في العمود  d  حيث تتركز عمليات  الجمع  والطرح  على سبيل  المثال  الكود  aa1=250+120-50-50+50=320 

Sub sumsub()
 Dim Ary As Variant
 Dim Dic As Object
 Dim i As Long
 Dim Cl As Range
 
 Set Dic = CreateObject("scripting.dictionary")
 Ary = Array("sheet1", "sheet2", "Sheet5", "sheet3", "sheet4")
 With Sheets(Ary(0))
 .Range("A2:D" & .Range("A" & Rows.Count).End(xlUp).Row).Copy Sheets("Sheet6").Range("A" & Rows.Count).End(xlUp).Offset(1)
 End With
 With Sheets("Sheet6")
 For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
 Dic.Item(Cl.Value) = Cl.Offset(, 3).Value
 Next Cl
 End With
 For i = 1 To UBound(Ary)
 With Sheets(Ary(i))
 For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
 If Dic.Exists(Cl.Value) Then Dic.Item(Cl.Value) = IIf(i < 3, Dic.Item(Cl.Value) + Cl.Offset(, 3), Dic.Item(Cl.Value) - Cl.Offset(, 3))
 Next Cl
 End With
 Next i
 Sheets("Sheet6").Range("D2").Resize(Dic.Count).Value = Application.Transpose(Dic.items)
End Sub

 

_users And sheets.xlsm

[سليم حاصبيا]

تصحيح الكود

Sub sumsub()
  Dim Ary     As Variant
  Dim Dic     As Object
  Dim i%
  Dim Cl      As Range
  Dim M
 
 Set Dic = CreateObject("scripting.dictionary")
 Ary = Array("sheet1", "sheet2", "Sheet5", "sheet3", "sheet4")
 
 With Sheets("Sheet6")
    For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(3))
     Dic.Item(Cl.Value) = Cl.Offset(, 3).Value
    Next Cl
 End With
    
    For i = 0 To UBound(Ary) - 1
        With Sheets(Ary(i))
          For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(3))
            If Dic.Exists(Cl.Value) Then
              M = Dic.Exists(Cl.Value)
              M = IIf(i < 3, M + Cl.Offset(, 3), _
              M - Cl.Offset(, 3))
              Dic(Cl.Value) = M
            End If
          Next Cl
        End With
    Next i
 Sheets("Sheet6").Range("D2").Resize(Dic.Count).Value = _
 Application.Transpose(Dic.items)
 Set Dic = Nothing: Set Cl = Nothing: Erase Ary
End Sub

 

[عبدالفتاح في بي اكسيل]

استاد سليم شكرا على محاولتك  ولكن اصبح الكود  لا يعمل  ولا يكتب سوى كلمة balance  في  العمود d في الورقة 6

[سليم حاصبيا]

 عندي يعمل بشكل طبيعي (عدّ ل على الماكرو كما تريد لاني لا أعرف بالضبط ما المقصود منه)

 

_users And sheets.xlsm

[عبدالفتاح في بي اكسيل]

شيء غريب استاد  سليم   لقد  قمت  بتنزيل  ملفك  وقمت بمسح  بيانات الورقة 6  وقمت  بتنفيد  الماكرو  وهذا  ما ظهر  كما في  الصورة 

حت تعلم  ما  اريد  عبارة  عن عمليات محاسبية   الورقة1=رصيد  اول  المدة  والورقة الثانية مشتريات  والورقة الثالثة مردودات  مشتريات  والورقة  الرابعة مبيعات  والورقة  الخامسة مردودات مبيعات   

فبالتالي  كما ذكرت  في  اول  المشاركة  تكون  المعادلة  في  العمود d  في  الورقة  السادسة  كالتالي رصيد اول  المدة +مشتريات -مردودات مشتريات -مبيعات +مردودات مبيعات 

[سليم حاصبيا]

اعنقد هذا الماكرو يقوم بما تريد

Sub Salim_sum()
  Dim Ary     As Variant
  Dim Dic     As Object
  Dim i%, x%, Ro%, k
  Dim itm
 If Sheets("ALL").Range("A1"). _
    CurrentRegion.Rows.Count > 1 Then _
    Sheets("ALL").Range("A2"). _
    CurrentRegion.Offset(1).ClearContents

 
 Set Dic = CreateObject("scripting.dictionary")
 Ary = Array("Plus_1", "Plus_2", "Minus_1", "Minus_2", "Plus_5")
 For Each itm In Ary
    x = IIf(Sheets(itm).Name Like "P*", 1, -1)
     Ro = Sheets(itm).Range("a1").CurrentRegion.Columns(1).Rows.Count
      For i = 2 To Ro
        k = IIf(IsNumeric(Sheets(itm).Range("D" & i)), _
            Sheets(itm).Range("D" & i), 0)
        If Not Dic.Exists(Sheets(itm).Range("A" & i).Value) Then
          Dic(Sheets(itm).Range("A" & i).Value) = x * (k)
        Else
           Dic(Sheets(itm).Range("A" & i).Value) = _
           Dic(Sheets(itm).Range("A" & i).Value) + x * (k)
        End If
      Next i
Next itm
Sheets("ALL").Range("A2").Resize(Dic.Count) = _
 Application.Transpose(Dic.keys)

Sheets("ALL").Range("D2").Resize(Dic.Count) = _
 Application.Transpose(Dic.Items)
 
 Set Dic = Nothing: Set Cl = Nothing: Erase Ary
End Sub

الملف مرفق

 

_My_sum.xlsm

[عبدالفتاح في بي اكسيل]

احسنت استاد  سليم نفعنا  الله بعلمك  هذا المطلوب