İsim listesine göre excel sayfası oluşturma ve tabloyu sayfa içerisine çekme

[seahmet]

Kolay gelsin arkadaşlar. ÖRNEK teki excel dosyasında listedeki kişilerin isimlerine göre sayfa oluşturup. Oluşturulan sayfanın içerisine tabloyu çekip üst tarafa'da Ad Soyad ve TC nin gelebileceği VBA kodu konusunda yardımcı olabilir misiniz. İsim listesi çok uzun olabilir.

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?
Kodla birlikte 2 adet te Function var. Bunlardan biri Sayfanın olup olmadığını, diğeri de Büyük/Küçük Harf ve Yazım Düzenini gerçekleştiren Fonksiyondur.
Kodda Sayfa İsmi değil Sayfa İndisi kullanılmıştır, sizde indis değişik ise İsim listesi olan sayfanın indisini Sayfa1, Tablo sayfasının indisini ise Sayfa2 olarak belirtin.

Public Sub SayfaAc()

Dim i   As Long, _
    j   As Integer, _
    rng As Range, _
    arr As Variant, _
    shf As String, _
    hata As String

Set rng = Sayfa2.Range("A1").CurrentRegion
arr = Sayfa1.Range("A1").CurrentRegion.Value

Application.ScreenUpdating = False

For i = 2 To UBound(arr, 1)
    arr(i, 2) = BKH(CStr(arr(i, 2)))
    arr(i, 3) = BKH(CStr(arr(i, 3)))
    shf = arr(i, 2) & " " & arr(i, 3)
    If SayfaVar(shf) = False Then
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = shf
        rng.Copy ActiveSheet.Range("A4")
        For j = 2 To 4
            ActiveSheet.Cells(1, j - 1) = arr(1, j)
            ActiveSheet.Cells(2, j - 1) = arr(i, j)
        Next j
        ActiveSheet.Cells.EntireColumn.AutoFit
    Else
        hata = hata & Chr(10) & shf
    End If
    
Next i

Sayfa1.Select

Application.ScreenUpdating = True

If Len(hata) > 0 Then
    MsgBox "SAYFASI OLUŞTURULAMAYANLAR LİSTESİ " & Chr(10) & hata
End If

End Sub

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

Function BKH(Sozcuk As String, Optional Tip As Integer = 2) As String

    'Tip    1. Küçük Harf
    '       2. Büyük Harf
    '       3. Yazım Düzeni
    
    Sozcuk = Application.WorksheetFunction.Trim(Sozcuk)
    If Tip = 1 Then
        BKH = Evaluate("=LOWER(" & """" & Sozcuk & """" & ")")
    ElseIf Tip = 2 Then
        BKH = Evaluate("=UPPER(" & """" & Sozcuk & """" & ")")
    Else
        BKH = Application.WorksheetFunction.Proper(Sozcuk)
    End If
    
End Function

 

[seahmet]

Necdet hocam elinize sağlık tam istediğim gibi olmuş. Çok teşekkür ederim. Allah razı olsun.