اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

السلام  عليكم 

الى خبراء  الاكسيل  احتاج  الى تعديل  الكود     حيث  الكود   لا يعمل  جيدا  بالنسبة  لعملية  الجمع  والطرح  في  العمود 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

رابط هذا التعليق
شارك

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

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

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

dd.JPG

رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information