Soru Yinelenen Değer

[husocan005]

Hocam başka sayfaya aktarılması yeterlidir.

 

[Korhan Ayhan]

Deneyiniz.

Dosyanıza Sayfa2 adında bir sayfa ekledikten sonra deneyiniz.

Option Explicit

Sub Transfer_Duplicate_Records()
    Dim S1 As Worksheet, S2 As Worksheet, My_Array As Object
    Dim Last_Row As Long, My_Data As Variant, Process_Time As Double
    Dim X As Long, Record_Count As Long, Y As Integer
    
    Process_Time = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    
    S2.Cells.Clear
    
    Last_Row = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Last_Row < 3 Then Last_Row = 3
    
    My_Data = S1.Range("A1:M" & Last_Row).Value2
    
    ReDim My_List(1 To S1.Rows.Count, 1 To 13)
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        My_Array(My_Data(X, 1)) = My_Array(My_Data(X, 1)) + 1
    Next
    
    Record_Count = 1
    
    For Y = 1 To 13
        My_List(Record_Count, Y) = My_Data(1, Y)
    Next
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Array.Item(My_Data(X, 1)) > 1 Then
            Record_Count = Record_Count + 1
            For Y = 1 To 13
                My_List(Record_Count, Y) = My_Data(X, Y)
            Next
        End If
    Next
    
    S2.Range("A1").Resize(Record_Count, UBound(My_List, 2)) = My_List
    S2.Range("M1").Offset(1, 0).Resize(Record_Count - 1).NumberFormat = "0"
    S2.Columns.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set My_Array = Nothing
    
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second"
End Sub

 

[husocan005]

Olmadı hocam Run time Error 9 Subscript out of range diye bir hata cıktı

 

[husocan005]

Tamam hocam oldu 12 saniyede aktardı. Sayfa1 degildi gerçek çalışma sayfamdaki onu değiştirdim Çalıştı. Emeğinize sağlık çok teşekkür ederim