عبدالفتاح في بي اكسيل قام بنشر أبريل 8, 2020 مشاركة قام بنشر أبريل 8, 2020 السلام عليكم الى خبراء الاكسيل احتاج الى تعديل الكود حيث الكود لا يعمل جيدا بالنسبة لعملية الجمع والطرح في العمود 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 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر أبريل 9, 2020 مشاركة قام بنشر أبريل 9, 2020 تصحيح الكود 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 رابط هذا التعليق شارك More sharing options...
عبدالفتاح في بي اكسيل قام بنشر أبريل 9, 2020 الكاتب مشاركة قام بنشر أبريل 9, 2020 استاد سليم شكرا على محاولتك ولكن اصبح الكود لا يعمل ولا يكتب سوى كلمة balance في العمود d في الورقة 6 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر أبريل 9, 2020 مشاركة قام بنشر أبريل 9, 2020 عندي يعمل بشكل طبيعي (عدّ ل على الماكرو كما تريد لاني لا أعرف بالضبط ما المقصود منه) _users And sheets.xlsm رابط هذا التعليق شارك More sharing options...
عبدالفتاح في بي اكسيل قام بنشر أبريل 9, 2020 الكاتب مشاركة قام بنشر أبريل 9, 2020 شيء غريب استاد سليم لقد قمت بتنزيل ملفك وقمت بمسح بيانات الورقة 6 وقمت بتنفيد الماكرو وهذا ما ظهر كما في الصورة حت تعلم ما اريد عبارة عن عمليات محاسبية الورقة1=رصيد اول المدة والورقة الثانية مشتريات والورقة الثالثة مردودات مشتريات والورقة الرابعة مبيعات والورقة الخامسة مردودات مبيعات فبالتالي كما ذكرت في اول المشاركة تكون المعادلة في العمود d في الورقة السادسة كالتالي رصيد اول المدة +مشتريات -مردودات مشتريات -مبيعات +مردودات مبيعات رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر أبريل 9, 2020 أفضل إجابة مشاركة قام بنشر أبريل 9, 2020 اعنقد هذا الماكرو يقوم بما تريد 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 1 رابط هذا التعليق شارك More sharing options...
عبدالفتاح في بي اكسيل قام بنشر أبريل 9, 2020 الكاتب مشاركة قام بنشر أبريل 9, 2020 احسنت استاد سليم نفعنا الله بعلمك هذا المطلوب 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان