مشكلة في الكود عند تنفيذه يطول ولا يجمع الأنواع المتساوية

[goodfas]

بسم الله الرحمن الرحيم

السلام عليكم ورحمة الله وبركاته

مشكلة في الكود عند تنفيذه يطول ولا يجمع الأنواع المتساوية من العمود A بسم واحد من كل نوع ويضعها في العمود B ومجمع كل

نوع في العمود C كعدد.

شرح الطلب أكثر في الملف المرفق

ولكم جزيل الشكر والتقدير,,,,

CAR Control.rar

تم تعديل يناير 11, 2013 بواسطه goodfas

[عبدالله باقشير]

السلام عليكم

جرب هذا الكود:

Sub kh_Sum()

Dim objlist

Dim r As Integer, i As Integer

Dim MyKey As String

Dim zz() As String

Set objlist = CreateObject("Scripting.Dictionary")

'''''''''''''''''''''''''''''


With ورقة2

    .Range("B2:D1000").ClearContents

    For r = 2 To 1000

        MyKey = CStr(.Cells(r, "A"))

        If MyKey <> "0" Then

            If Not objlist.Exists(MyKey) Then

                i = i + 1

                objlist.Add MyKey, i

                ReDim Preserve zz(1 To 2, 1 To i)

                zz(1, i) = MyKey

                zz(2, i) = WorksheetFunction.CountIf(.Range("A2:A1000"), MyKey)

            End If

        End If

    Next

End With

'''''''''''''''''''''''''''''


If i Then

    With ورقة2

        .Range("B2").Resize(i, 2).Value = WorksheetFunction.Transpose(zz)

    End With

End If


'''''''''''''''''''''''''''''


Set objlist = Nothing

Erase zz

End Sub

المرفق2003

CAR Control1.rar

[goodfas]

استاذى الغالى/ عبدالله باقشير

تسلم إيدك ودائما سباق لعمل الخير

بارك الله فيك وزادك من علمه ونفعك به وجعلة الله فى ميزان حسناتك

هذا هو المطلوب تسلم,,,