لدي مجموعة اكواد متكرره وفي مقابلها ارقام اريد حذف المتكرر مع جمع الارقام المقابله للمحذوف

[خالد عبدالجواد]

لدي مجموعة اكواد متكرره وفي مقابلها ارقام اريد حذف المتكرر مع جمع الارقام المقابله للمحذوف

StockReport(2).rar

[ياسر خليل أبو البراء]

السلام عليكم

إليك الرابط التالي فيه موضوع مشابه تماماً لموضوعك

http://laernoffice.com/2016/12/23/استخراج-القيم-الفريدة-وجمع-القيم-في-ال/

[أبو عبد النور]

السلام عليكم،

لعد إذن الاستاذ ياسر، هاك حل آخر.

 

StockReport_(v001).rar

[ياسر خليل أبو البراء]

وعليكم السلام أخي الكريم أبو عبد النور

بارك الله فيك على الكود الجميل .. 

يعيب الكود فقط أنه لابد أن تكون القيم المتشابهة متتالية وإلا لن تكون النتائج صحيحة ... 

أما الكود الذي قدمته لم أجربه على الملف لكن يعيب أنه لابد من التخلص من المسافات الزائدة لذا وجب إضافة إلى الكود لكي يتلاشى خطأ المسافات والكود بهذا الشكل

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

 

[أبو عبد النور]

اهلا اخي ياسر،

الناتج فعلا ليس به مسافات لاني قمت بحفذفها اثناء المعالجة.

فكرتك في الحل جميلة ايضا

عدلت الكود (وهو حدف المكرر بدل استخراجه مثل المرة الاولى)

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

 

[خالد عبدالجواد]

شكرا جدا جدا جزاكم الله خيرا علي الرد

ولكني مستخدم جديد للاكسيل ولا اعرف كيف اضع هذا الكود وطريقة تفعيله

لاني استخدم هذا الشيت يوميا لمعرفة رصيدي من تلك الاكواد

[خالد عبدالجواد]

شكرا جدا جدا جزاكم الله خيرا علي الرد

منذ ساعه, ياسر خليل أبو البراء 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

 

شكرا جدا هذا الكود اشتغل معايا كويس جدا جدا جزاكم الله خيرا

[خالد عبدالجواد]

لو سمحت اريد استخدام هذا الكود لملف اخر يحمل اسم مختلف وخانة الكمية 3 بدل 2

new.rar

[خالد عبدالجواد]

لو سمحت مفيش حد يساعدني طيب اطبق الكود ده ازاي علي ملف مش فيه فراغات في الخلايا Trim