خالد عبدالجواد قام بنشر ديسمبر 23, 2016 مشاركة قام بنشر ديسمبر 23, 2016 لدي مجموعة اكواد متكرره وفي مقابلها ارقام اريد حذف المتكرر مع جمع الارقام المقابله للمحذوف StockReport(2).rar رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر ديسمبر 23, 2016 مشاركة قام بنشر ديسمبر 23, 2016 السلام عليكم إليك الرابط التالي فيه موضوع مشابه تماماً لموضوعك http://laernoffice.com/2016/12/23/استخراج-القيم-الفريدة-وجمع-القيم-في-ال/ رابط هذا التعليق شارك More sharing options...
أبو عبد النور قام بنشر ديسمبر 23, 2016 مشاركة قام بنشر ديسمبر 23, 2016 السلام عليكم، لعد إذن الاستاذ ياسر، هاك حل آخر. StockReport_(v001).rar رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر ديسمبر 23, 2016 مشاركة قام بنشر ديسمبر 23, 2016 وعليكم السلام أخي الكريم أبو عبد النور بارك الله فيك على الكود الجميل .. يعيب الكود فقط أنه لابد أن تكون القيم المتشابهة متتالية وإلا لن تكون النتائج صحيحة ... أما الكود الذي قدمته لم أجربه على الملف لكن يعيب أنه لابد من التخلص من المسافات الزائدة لذا وجب إضافة إلى الكود لكي يتلاشى خطأ المسافات والكود بهذا الشكل Sub UniqueListAndSum() Dim ws As Worksheet Dim i As Long Dim j As Long Dim k As Long Dim x, y() ReDim y(1 To Rows.Count, 1 To 2) With CreateObject("Scripting.Dictionary") .CompareMode = 1 Set ws = Sheets("StockReport") x = ws.Range("A1:B" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value For i = 2 To UBound(x) x(i, 1) = Trim(x(i, 1)) If Len(x(i, 1)) Then If .Exists(x(i, 1)) Then k = .Item(x(i, 1)) y(k, 2) = y(k, 2) + x(i, 2) Else j = j + 1 .Item(x(i, 1)) = j y(j, 1) = x(i, 1) y(j, 2) = x(i, 2) End If End If Next i End With With ws .Columns("I:J").ClearContents .Range("I1:J1") = Array("Names", "Quantity") .Range("I2").Resize(j, 2).Value = y() End With End Sub 1 رابط هذا التعليق شارك More sharing options...
أبو عبد النور قام بنشر ديسمبر 23, 2016 مشاركة قام بنشر ديسمبر 23, 2016 اهلا اخي ياسر، الناتج فعلا ليس به مسافات لاني قمت بحفذفها اثناء المعالجة. فكرتك في الحل جميلة ايضا عدلت الكود (وهو حدف المكرر بدل استخراجه مثل المرة الاولى) Sub StockReport() Dim Ts(), Tb() Dim j As Integer Dim i As Integer Dim Sm As Integer Sm = 0 Ts = Range([A2], Cells(Rows.Count, 1).End(xlUp)).Value For i = 2 To UBound(Ts) If Trim(Ts(i, 1)) = Trim(Ts(i - 1, 1)) Then Sm = Sm + 1 Else j = j + 1 ReDim Preserve Tb(1 To 2, 1 To j) Tb(1, j) = Trim(Ts(i - 1, 1)) End If If i = UBound(Ts) Then j = j + 1 ReDim Preserve Tb(1 To 2, 1 To j) Tb(1, j) = Trim(Ts(i, 1)) End If Next [E:F].ClearContents [E2].Resize(UBound(Tb, 2), UBound(Tb, 1)).Value = Application.Transpose(Tb) [F2] = Sm & " من الأرقام تم حدفها " End Sub رابط هذا التعليق شارك More sharing options...
خالد عبدالجواد قام بنشر ديسمبر 23, 2016 الكاتب مشاركة قام بنشر ديسمبر 23, 2016 شكرا جدا جدا جزاكم الله خيرا علي الرد ولكني مستخدم جديد للاكسيل ولا اعرف كيف اضع هذا الكود وطريقة تفعيله لاني استخدم هذا الشيت يوميا لمعرفة رصيدي من تلك الاكواد رابط هذا التعليق شارك More sharing options...
خالد عبدالجواد قام بنشر ديسمبر 23, 2016 الكاتب مشاركة قام بنشر ديسمبر 23, 2016 شكرا جدا جدا جزاكم الله خيرا علي الرد منذ ساعه, ياسر خليل أبو البراء said: وعليكم السلام أخي الكريم أبو عبد النور بارك الله فيك على الكود الجميل .. يعيب الكود فقط أنه لابد أن تكون القيم المتشابهة متتالية وإلا لن تكون النتائج صحيحة ... أما الكود الذي قدمته لم أجربه على الملف لكن يعيب أنه لابد من التخلص من المسافات الزائدة لذا وجب إضافة إلى الكود لكي يتلاشى خطأ المسافات والكود بهذا الشكل Sub UniqueListAndSum() Dim ws As Worksheet Dim i As Long Dim j As Long Dim k As Long Dim x, y() ReDim y(1 To Rows.Count, 1 To 2) With CreateObject("Scripting.Dictionary") .CompareMode = 1 Set ws = Sheets("StockReport") x = ws.Range("A1:B" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value For i = 2 To UBound(x) x(i, 1) = Trim(x(i, 1)) If Len(x(i, 1)) Then If .Exists(x(i, 1)) Then k = .Item(x(i, 1)) y(k, 2) = y(k, 2) + x(i, 2) Else j = j + 1 .Item(x(i, 1)) = j y(j, 1) = x(i, 1) y(j, 2) = x(i, 2) End If End If Next i End With With ws .Columns("I:J").ClearContents .Range("I1:J1") = Array("Names", "Quantity") .Range("I2").Resize(j, 2).Value = y() End With End Sub شكرا جدا هذا الكود اشتغل معايا كويس جدا جدا جزاكم الله خيرا رابط هذا التعليق شارك More sharing options...
خالد عبدالجواد قام بنشر يناير 15, 2017 الكاتب مشاركة قام بنشر يناير 15, 2017 لو سمحت اريد استخدام هذا الكود لملف اخر يحمل اسم مختلف وخانة الكمية 3 بدل 2 new.rar رابط هذا التعليق شارك More sharing options...
خالد عبدالجواد قام بنشر يناير 19, 2017 الكاتب مشاركة قام بنشر يناير 19, 2017 لو سمحت مفيش حد يساعدني طيب اطبق الكود ده ازاي علي ملف مش فيه فراغات في الخلايا Trim رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان