إذا امكن مساعدة بخصوص تكرار الاسماء

[ali244]

السلام عليكم 

من بعد اذن الاستاذة الكرام اريد مساعدة بخصوص نقل الاسماء المتكررة إلى ورقة عمل جديدة

ومشكورين

المصنف1.xlsx

[lionheart]

Sub Test()
    Dim ws As Worksheet, lr As Long, r As Long, m As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        m = 1
        With Worksheets(1)
            lr = .Cells(Rows.Count, 1).End(xlUp).Row
            With .Range("B1:B" & lr)
                .Formula = "=COUNTIF($A$1:A1,A1)"
                .Value = .Value
            End With
            For r = lr To 1 Step -1
                If .Cells(r, 2).Value > 1 Then
                    ws.Cells(m, 1).Value = .Cells(r, 1).Value
                    m = m + 1
                    .Rows(r).Delete
                End If
            Next r
            .Columns(2).ClearContents
        End With
        If m = 1 Then
            Application.DisplayAlerts = False
                ws.Delete
            Application.DisplayAlerts = True
        End If
    Application.ScreenUpdating = True
    If m > 1 Then MsgBox "Names Moved = " & m - 1, 64 Else MsgBox "No Change", 64
End Sub

 

[ali244]

مشكور على المساعدة ولكن إذا أمكن أن يكون الحل ابسط من ذلك ( عن طريق الدوال)

[lionheart]

You can't use formulas to move rows or delete rows and the code is very simple and it is basic

[ali244]

مشكور