alfabetik sıralı iki listedeki aynı kayıtları farklı sayfalara kopyalama

[angurya]

Merhabalar, İki ayrı sayfamda alfabetik ve nümerik karakterlerden oluşan firma ünvanları bulunuyor. Ben bunları kendi aralarında alfabetik ve nümerik isimlerden oluşan şekliyle ayırıp farklı sayfalara kopyalamak istiyorum.

Mesala listedeki A ile başlayan kayıtları A isimli sayfaya , B ile başlayan kayıtları B isimli sayfaya 3 veya başka karakterde bulunanları 3 isimli sayfaya aktarılması,

Aşağıya örnek bir dosya ekliyorum.

İlgilenecek arkadaşlara şimdiden teşekkür ediyorum.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Sayfa_Olustur_Aktar()
    
    Dim c   As String, _
        ce  As String, _
        i   As Long, _
        j   As Long, _
        ShV As Worksheet
    
    Set ShV = Sheets("veri")
    
    Application.ScreenUpdating = False
    
    For i = 2 To ShV.Cells(Rows.Count, "A").End(3).Row
    
        c = Left(ShV.Cells(i, "C"), 1)
        If Not c = ce Then
            ce = c
            If Not SayfaVarMi(c) Then
                Sheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = c
                ShV.Select
            End If
            j = Sheets(c).Cells(Rows.Count, "A").End(3).Row
        End If
        
        j = j + 1
        Range("A" & i & ":E" & i).Copy Sheets(c).Range("A" & j)
        
    Next i
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

 

[suleyman242]

Dosyayı incelermisin.

 

[angurya]

Necdet Hocam, Emeğiniz için çok teşekkür ediyorum. Çok sağ olun.