استخراج القيم الغير مكررة من عمودين وجمع الإجمالي الخاص بيهم باستخدام كائن القاموس

Option Explicit

Sub Mycode()

Dim dic As Object

Dim A As Worksheet

Dim N As Worksheet

Dim m%, i%, ky, t%, last_ro%, Fix_Ro%, Act_Ro%

Dim Rg_A As Range, F_rg As Range

Dim arr_col()



Application.ScreenUpdating = False

Set A = Sheets("ayman"): Set N = Sheets("nour")

Set Rg_A = A.Range("a4").CurrentRegion.Columns(2)

Set dic = CreateObject("Scripting.Dictionary")

If N.Range("c1").CurrentRegion.Rows.Count > 1 Then _

    N.Range("c1").CurrentRegion.Offset(1).Clear

For i = 2 To Rg_A.Rows.Count

 dic(Rg_A.Cells(i).Value) = vbNullString

 Next

 arr_col = Array(2, 4, 5, 11, 12, 14, 15, 21, 22)



 m = 2

 For Each ky In dic.keys

  Set F_rg = Rg_A.Find(ky, Lookat:=1)

   Fix_Ro = F_rg.Row: Act_Ro = Fix_Ro

    Do

    t = t + 1

      With N.Cells(m, 2)

        For i = 0 To 8

         .Offset(, i) = A.Cells(Act_Ro, arr_col(i))

        Next

      End With

       m = m + 1

      Set F_rg = Rg_A.FindNext(F_rg)

      Act_Ro = F_rg.Row

      If Act_Ro = Fix_Ro Then Exit Do

   Loop

    Cells(m, 1) = "المجموع"

    Cells(m, 5).Resize(, 2).Formula = "=SUM(E" & m - t & ":E" & m - 1 & ")"

    Cells(m, 9).Resize(, 2).Formula = "=SUM(I" & m - t & ":I" & m - 1 & ")"

    Cells(m, 1).Resize(, 10).Interior.ColorIndex = 6

    m = m + 1

    t = 0

  Next ky

      With N.Range("A1").CurrentRegion

        .Borders.LineStyle = 1

        .InsertIndent 1

        .Font.Size = 14

        .Font.Bold = True

        .Columns.AutoFit

        .Value = .Value

        .Rows(1).HorizontalAlignment = xlCenter

      End With

  

  Set dic = Nothing: Set A = Nothing

  Set N = Nothing: Set Rg_A = Nothing

  Set F_rg = Nothing: Set dic = Nothing

  Erase arr_col

    

 Application.ScreenUpdating = trus



End Sub

Option Explicit

Sub Mycode_new()

Dim Dic As Object

Dim ReP As Worksheet

Dim A As Worksheet

Dim m%, i%, ky, Fix_Ro%, Act_Ro%

Dim RG_D As Range, F_rg As Range

Dim arr_col()



Application.ScreenUpdating = False

Set ReP = Sheets("Repport"): Set A = Sheets("ayman")

Set RG_D = A.Range("A4").CurrentRegion.Columns(4)

Set Dic = CreateObject("Scripting.Dictionary")

If ReP.Range("C1").CurrentRegion.Rows.Count > 1 Then _

    ReP.Range("C1").CurrentRegion.Offset(1).Clear

For i = 2 To RG_D.Rows.Count

 Dic(RG_D.Cells(i).Value) = vbNullString

 Next

 arr_col = Array(4, 5, 11, 12, 14, 15, 21, 22)



 m = 2

 For Each ky In Dic.keys

  Set F_rg = RG_D.Find(ky, Lookat:=1)

   Fix_Ro = F_rg.Row: Act_Ro = Fix_Ro

   Do

        With ReP.Cells(m, 2)

          For i = 0 To 7

           .Offset(, i) = A.Cells(Act_Ro, arr_col(i))

          Next

        End With

         m = m + 1

        Set F_rg = RG_D.FindNext(F_rg)

        Act_Ro = F_rg.Row

        If Act_Ro = Fix_Ro Then Exit Do

   Loop

  Next ky

      With ReP.Range("B2").Resize(m - 2, 8)

        .Borders.LineStyle = 1

        .InsertIndent 1

        .Font.Size = 14

        .Font.Bold = True

      

      End With

  

  Set Dic = Nothing: Set ReP = Nothing

  Set A = Nothing: Set RG_D = Nothing

  Set F_rg = Nothing: Erase arr_col

  

    

 Application.ScreenUpdating = True



End Sub

Sub ayman_333()



'الكود خاص بالاستاذ العلامة ياسر خليلاعزة الله

'وتم التعديل علية فى بعض الاماكن ليناسب النتائج

    

    Dim ws          As Worksheet

    Dim sh          As Worksheet

    Dim dic         As Object

    Dim a           As Variant

    Dim s           As String

    Dim i           As Long

    Dim j           As Long

    '--------------------------------------------------------------------------------

    Set ws = ThisWorkbook.Sheets("ayman")

    Set sh = ThisWorkbook.Sheets("nour")

    Set dic = CreateObject("scripting.dictionary")

    a = ws.Range("A3:V" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Value

    '--------------------------------------------------------------------------------

    For i = LBound(a, 1) To UBound(a, 1)

        s = a(i, 4) & vbTab & a(i, 5)

        If Not dic.Exists(s) Then dic(s) = Array(, , 0, 0)

        dic(s) = Array(a(i, 4), a(i, 5), dic(s)(2) + a(i, 11), dic(s)(3) + a(i, 12))

    Next i

    '--------------------------------------------------------------------------------

    For j = LBound(a, 1) To UBound(a, 1)

        s = a(j, 14) & vbTab & a(j, 15)

        If Not dic.Exists(s) Then dic(s) = Array(, , 0, 0)

        dic(s) = Array(a(j, 14), a(j, 15), dic(s)(2) + a(j, 21), dic(s)(3) + a(j, 22))

    Next j

    '--------------------------------------------------------------------------------

    sh.Range("A1").Resize(1, 4).Value = Array("اســم المــــدرس", "المجمـــــوعة", "المقدم", "الباقى")

    sh.Range("A2").Resize(dic.Count, 4).Value = Application.Transpose(Application.Transpose(dic.items))

    '--------------------------------------------------------------------------------

'هذا الجزء تم اضافتة للكود لازالة الاصفار

'الموجودةاسفل اعمدة المقدم والباقي

'    lm = sh.Range("C" & Rows.Count).End(xlUp).Row

'   sh.Range("C" & lm).Select

'    Range(Selection, Selection.End(xlToRight)).Select

'    Selection.ClearContents

End Sub

Sub CenterAccts()

Dim ws As Worksheet, Sh As Worksheet

Dim C As Range, y As Long, z As Long

Dim Arr As Variant, Temp As Variant, yy As Long, zz As Long

Dim LR As Long, I As Long, p As Long, x As Integer, j As Integer

t = Timer

Application.ScreenUpdating = False

Set ws = Sheets("ayman")

Set Sh = Sheets("nour")

LR = ws.Range("B" & Rows.Count).End(xlUp).Row

Arr = ws.Range("A3:V" & LR)

ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))

For I = 1 To UBound(Arr, 1)

x = WorksheetFunction.CountIfs(ws.Range("D3:D" & I + 2), Arr(I, 4), _

ws.Range("E3:E" & I + 2), Arr(I, 5))

If x = 1 Then

p = p + 1

For j = 1 To 2

Temp(p, j) = Arr(I, Choose(j, 4, 5))

Next

End If

Next

If p > 0 Then Sh.Range("C2").Resize(p, 4) = Temp

For Each C In Sh.Range("C2:C" & Sh.Range("C" & Rows.Count).End(xlUp).Row)

S = C.Offset(0, 1)

y = WorksheetFunction.SumIfs(ws.Range("K2:K" & LR), _

ws.Range("D2:D" & LR), C, ws.Range("E2:E" & LR), S)

yy = WorksheetFunction.SumIfs(ws.Range("U2:U" & LR), _

ws.Range("N2:N" & LR), C, ws.Range("O2:O" & LR), S)



z = WorksheetFunction.SumIfs(ws.Range("L2:L" & LR), _

ws.Range("D2:D" & LR), C, ws.Range("E2:E" & LR), S)

zz = WorksheetFunction.SumIfs(ws.Range("V2:V" & LR), _

ws.Range("N2:N" & LR), C, ws.Range("O2:O" & LR), S)



C.Offset(0, 2) = y + yy

C.Offset(0, 3) = z + zz

Next

Application.ScreenUpdating = True

MsgBox Round(Timer - t, 2)

End Sub