Çözüldü İsim listesi

[yuzun23]

Üstadlarım, ekteki dosyada VERİ listesindeki isimlerin, isimlerin baş harfinin bulunduğu sekmenlere dağılması gerekiyor yardımlarınızı bekliyorum. şimdiden teşekkürler.
veri deki isim sayısı en az 200 olabilir

 

[DoğanD]

Merhaba,

Yedek alıp dener misiniz?

Sub dd()
Dim i, satir
For i = 2 To Sayfa1.Range("A" & Rows.Count).End(xlUp).Row
satir = Sheets(Left(Sayfa1.Cells(i, 1), 1)).Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets(Left(Sayfa1.Cells(i, 1), 1)).Range("A" & satir & ":C" & satir) = Sayfa1.Range("A" & i & ":C" & i).Value
Next i
End Sub

 

[yuzun23]

OLMADI. veya BECEREMEDİM .MACRO KONUSUNDA İYİ DEĞİLİM

 

[DoğanD]

Dosyayı ekledim, Veri sayfasındaki buton ile kullanabilirsiniz.

 

[yuzun23]

DÜĞMEYE BASTIĞIMDA, ÖNCEKİ İSİMLERİ TEKRAR YAZIYOR, YANİ HER BUTONA BASTIĞIMDA AYNI İSİMLERİ TEKRARLIYOR

 

[Necdet]

Merhaba,
Alternatif olsun.

Sub Dagit()

Dim sh  As String
Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim c   As Range
Dim ShV As Worksheet
Dim arr As Variant
Dim adt As Long

Set ShV = Sheets("VERİ")

arr = ShV.Range("A1").CurrentRegion

For i = 2 To UBound(arr, 1)
    sh = Left(arr(i, 1), 1)
    Set c = Sheets(sh).Range("A:A").Find(arr(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
    If c Is Nothing Then
        adt = adt + 1
        j = Sheets(sh).Cells(Rows.Count, "A").End(3).Row + 1
        For k = 1 To UBound(arr, 2)
            Sheets(sh).Cells(j, k) = arr(i, k)
        Next k
    End If
Next i

If adt = 0 Then
    MsgBox "Hiç Bir Kayıt Aktarılmamıştır...."
Else
    MsgBox adt & " Adet Kayıt AKTARILMIŞTIR...."
End If

End Sub

 

[muhasebeciyiz]

deneyiniz

 

[DoğanD]

DÜĞMEYE BASTIĞIMDA, ÖNCEKİ İSİMLERİ TEKRAR YAZIYOR, YANİ HER BUTONA BASTIĞIMDA AYNI İSİMLERİ TEKRARLIYOR

Merhaba,

İhtiyacınız olanı siz daha iyi biliyorsunuz. Bu sebeple de ilk sorunuzda daha kapsamlı bir açıklama yapmanızı tavsiye edebilirim. Dağıtımı yapmadan önce sayfalardaki verileri temizlemeyi de ekledim, kontrol edebilir misiniz?

 

[yuzun23]

ellerinize sağlık