عدم تكرار الموظف ودمجة فى خلية واحدة

[mohamed322]

عدم تكرار الموظف ودمجة فى خلية واحدة

عدم تكرار الموظف.xls

[سليم حاصبيا]

جرب هذا الماكرو

Option Explicit

Sub No_Duplicates()
Dim Dic As Object
Dim Mmax%, i%
Dim SH As Worksheet

Set SH = Sheets("Sheet1")
Set Dic = CreateObject("Scripting.Dictionary")
With SH
    If .Range("E1").CurrentRegion.Rows.Count > 1 Then _
     Range("E1").CurrentRegion.Offset(1).ClearContents
    
    Mmax = .Cells(Rows.Count, 1).End(3).Row
    i = 2
    Do Until i > Mmax
       If .Cells(i, 1) <> vbNullString Then
          If Not Dic.exists(.Cells(i, 1).Value) Then
            Dic(.Cells(i, 1).Value) = IIf(IsNumeric(.Cells(i, 2)), _
             .Cells(i, 2), 0)
           Else
            Dic(.Cells(i, 1).Value) = _
              Dic(.Cells(i, 1).Value) + _
              IIf(IsNumeric(.Cells(i, 2)), _
              .Cells(i, 2), 0)
          End If
      End If
      i = i + 1
   Loop
      If Dic.Count Then
       .Range("e2").Resize(Dic.Count) = _
       Application.Transpose(Dic.keys)
        .Range("F2").Resize(Dic.Count) = _
       Application.Transpose(Dic.items())
    End If
End With

End Sub

الملف مرفق

No_tekrar.xlsm

[mohamed322]

شكرااااااااااااااااااا جداااااااااااا بارك الله فيكم