Veri Kopyalama

[muyat]

Tekrar merhaba.
Şöyle bir sorum olcak
.Ekteki dosyada sayfa 1 de "O5" ve "p5"den başlayarak aşagı dogru 4 adet insan isim ve soyisimleri var.
Ben bunları sayfa'2de yukardan B2 hücresinden başlayıp içinde birleştirip isim ve soyisim arasında bir adet boşluk olcak şekilde ve c2den başlayıp tc numaraları yazacak şekilde yukardan aşagıya dogru sadece makroyu çalıştırınca kopyalamak istiyorum
Yalnız benim istedigim şey şu:
Sayfa 1 de bazı zamanlar "O5" ve "p5"den aşagıya dogru bazen 4, bazen 1,bazen 2, bazen 10 "tane isim oluyor.Yani kaç tane isim olacagı belirsiz.O nedenle makroyu çalıştırınca işlemin kaç kez tekrar etmesi gerektiğini hesaplattıramadım.
Bu senaryoya uyacak şekilde ilgili kodları yazar mısınız.

 

[çıtır]

Deneyiniz

Sub Sayfayaal()
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim son As Long
Dim sd As Object: Dim i As Long: Dim liste(): Dim Dizi()
   Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
   Set wf = WorksheetFunction
   Application.ScreenUpdating = False
        
    son = s2.Cells(1048541, "B").End(3).Row
    sy = wf.CountA(s1.Range("N5:N65355"))
    liste = s1.Range("N5:P" & sy + 5).Value
    Set sd = CreateObject("Scripting.Dictionary")
  
    For i = 1 To UBound(liste, 1)
    If liste(i, 1) <> "" Then
    aranan = liste(i, 1)
     If Not sd.Exists(aranan) Then
            say = say + 1
            sd.Add aranan, say
            ReDim Preserve Dizi(1 To sy, 1 To 2)
        Dizi(say, 1) = liste(i, 2) & " " & liste(i, 3)
        Dizi(say, 2) = liste(i, 1)
        End If
        End If
    Next i
If sd.Count > 0 Then
's1.Range("N5:P" & sy + 5).ClearContents
 Application.ScreenUpdating = True
s2.Range("B" & son + 1).Resize(sd.Count, 2) = Dizi
     End If
    
  i = Empty: son = Empty: Erase liste: Erase Dizi
  Set s1 = Nothing:   Set s2 = Nothing: Set sd = Nothing
    Set wf = Nothing
End Sub