Mükerrer kayıtların ayıklanması ve aktarımı

[vahapexcel]

Sayfa 1 de 5 kayıt mevcuttur

Sayfa 1 de bulunan 5 kayıttan 4. ve 5. sıradaki kayıtlar mükerrerdir.

Bu 5 kaydın mükerrer olmayan 3 kaydın liste 1'e atılmasını

Bu 5 kaydın mükerrer olan 2 kaydın ise liste 2'e atılmasını

Mükerrer olan kaydın 1. kayıt değil daha sonra gelen kaydın baz alınması

sağlamak

İlginiz için teşekkür

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[vahapexcel]

Ellerinize sağlık gayet iyi.
Teşekkür ederim.

 

[yanginci34]

Sayın muygun un izniyle Buda benden alternatif

 

[dEdE]

Merhaba,
Daha hızlı çalışacağını düşündüğüm başka bir alternatif.

Sub Test()
Dim myArr, myList As Variant
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Liste 1")
Set s3 = Sheets("Liste 2")
    ss = s1.Cells(Rows.Count, "B").End(3).Row
    s2.Range("A2:I" & s2.Rows.Count).ClearContents
    s3.Range("A2:I" & s3.Rows.Count).ClearContents
    sat2 = 2
    sat3 = 2
    myArr = s1.Range("A2:I" & ss)
    Set myList = CreateObject("System.Collections.ArrayList")
    Set myList1 = CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(myArr)
        If Not myList.Contains(myArr(i, 2)) Then
            myList.Add myArr(i, 2)
            For j = 1 To 9
                s2.Cells(sat2, j) = myArr(i, j)
            Next j
            sat2 = sat2 + 1
        Else
            myList1.Add myArr(i, 2)
            For j = 1 To 9
                s3.Cells(sat3, j) = myArr(i, j)
            Next j
            sat3 = sat3 + 1
        End If
    Next i
End Sub

 

[AdemCan]

3. alternatif döngüye örnek.

Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim s1s As Long, s2s As Long, s3s As Long, i As Long
    Set s1 = Sayfa1: Set s2 = Sayfa2: Set s3 = Sayfa3
    s1s = s1.Cells(Rows.Count, 2).End(3).Row
    s2s = s2.Cells(Rows.Count, 2).End(3).Row
    s3s = s3.Cells(Rows.Count, 2).End(3).Row
    s2.Range("A2:I" & s2s + 1).Clear: s3.Range("A2:I" & s3s + 1).Clear
        For i = s1s To 2 Step -1
            say = WorksheetFunction.CountIf(s1.Range("B" & i & ":B2"), s1.Cells(i, 2))
            If say = 1 Then
                s2s = s2.Cells(Rows.Count, 2).End(3).Row
                s1.Rows(i).Copy s2.Rows(s2s + 1)
            ElseIf say > 1 Then
                s3s = s3.Cells(Rows.Count, 2).End(3).Row
                s1.Rows(i).Copy s3.Rows(s3s + 1)
            End If
        Next i
Application.ScreenUpdating = True
End Sub

 

[veyselemre]

Sub Test()
    Dim lr&, i&, a, sat1&, sat2&

    Sheets("Liste 1").UsedRange.Offset(1).ClearContents
    Sheets("Liste 2").UsedRange.Offset(1).ClearContents

    With Sheets("Sayfa1")
        lr = .Cells(Rows.Count, 1).End(3).Row
        sat1 = 2: sat2 = 2
        For i = 2 To lr
            If Evaluate("= COUNTIF(B" & i & ":B" & lr & ",B" & i & ")") = 1 Then
                Sheets("Liste 1").Cells(sat1, 1).Resize(, 9).Value = .Cells(i, 1).Resize(, 9).Value
                sat1 = sat1 + 1
            Else
                Sheets("Liste 2").Cells(sat2, 1).Resize(, 9).Value = .Cells(i, 1).Resize(, 9).Value
                sat2 = sat2 + 1
            End If
        Next i
    End With
    
End Sub

 

[Tevfik_Kursun]

Merhaba Arkadaşlar,
İlgilenen arkadaşlara ben de teşekkür ederim. Sayın dEdE'nin makrosu hata veriyor. Nedenini anlamadım.
Saygılarımla

 

[dEdE]

...Sayın dEdE'nin makrosu hata veriyor. Nedenini anlamadım. ...

Merhaba,
System.Collections.ArrayList'in çalışması için bilgisayarda .NET Framework 3.5'in yüklü olması gerekir. Daha üst versiyonların yüklü olması yeterli olmuyor.

 

[Tevfik_Kursun]

Anladım, teşekkür ederim
Saygılarımla