اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

قام بنشر

أخي الكريم فارس

إليك الكود التالي عله يكون المطلوب

Sub ExtractUnique_Count()
    Dim R1 As Range, R2 As Range, Cel As Range, LR As Long
    Dim D1, D2, A1, A2
    
    LR = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    Set R1 = Sheet1.Range("B2:B" & LR)
    Set R2 = Sheet1.Range("D2:D" & LR)
    
    Set D1 = CreateObject("Scripting.Dictionary")
    Set D2 = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    
    Sheet3.Range("A2:E1000").ClearContents
    For Each Cel In R1
        If Cel <> 0 Then D1.Add CStr(Cel), CStr(Cel)
    Next Cel
    A1 = D1.Items
    
    For Each Cel In R2
        If Cel <> 0 Then D2.Add CStr(Cel), CStr(Cel)
    Next Cel
    A2 = D2.Items
    
    Sheet3.Range("A2").Resize(D1.Count) = Application.Transpose(A1)
    With Sheet3.Range("B2").Resize(D1.Count)
        .Formula = "=COUNTIF(ورقة1!$B$2:$B$1000,A2)"
        .Value = .Value
    End With
    
    Sheet3.Range("D2").Resize(D2.Count) = Application.Transpose(A2)
    With Sheet3.Range("E2").Resize(D2.Count)
        .Formula = "=COUNTIF(ورقة1!$D$2:$D$1000,D2)"
        .Value = .Value
    End With
End Sub

وإليك الملف المرفق فيه تطبيق للكود

تقبل تحياتي

Extract Unique Items & Count Them YasserKhalil.rar

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

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

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

Important Information