Hücre birleştirme

[muyat]

Merhabalar.
Ekteki dosyadaki programla şunu yapmak istiyorum.
Sayfa 1 deki kutucuga tıklayınca şehir ismi,tc,ad ve soyadlar sayfa 2 ye aktarılıyor.
Yalnız burda isimler ve tcler 5.satırdan başlıyor ve 4 adet isim var.Ve seçtigim bir hücrede bir şehir ismi var.
Fakat 1.sayfadaki bu isimleri bazen değiştiriyorum siliyorum.O nedenle sayı 4 de olabilir daha fazla da olabilir.2.sayfaya aktrma kısmında da sorun yok...
İlk sayfdaki kutucuga tıklayıp makroyu çalıştırınca o an kaç adet isim ve tc aktarmışsam her ismin başına şehir ismi otomatik yazılıyor..Ama istedigim şey şu :.Diyelimki 4 isim aktarmışsam aktarıldıktan sonra örnegin a sütununda her ismin sol tarafına "bursa"yazmak yerine bu 4 hücreyi birleştirip tek bir tane resimdeki gibi bursa yazıp ortalamasını istiyorum...
Bunu nasıl yapabiliriz.
Merge koduyla yapılacak ama halledemedim.
Aşagıdaki resimdeki gibi birleşsin istiyorum.

Sub Dikdörtgen1_Tıkla()
Set s1 = Sheets("Sayfa1"): Set S2 = Sheets("Sayfa2")
s1son = s1.Cells(Rows.Count, "N").End(3).Row
If s1son < 5 Then: MsgBox "Aktarılacak veri yok!", vbCritical: Exit Sub
For s1sat = 5 To s1son
    s2sat = S2.Cells(Rows.Count, 2).End(3).Row + 1
    S2.Cells(s2sat, 1) = s1.Cells(s1sat, "M")
    S2.Cells(s2sat, 2) = s1.Cells(s1sat, "O") & " " & s1.Cells(s1sat, "P")
    S2.Cells(s2sat, 3) = s1.Cells(s1sat, "N")

Sheets("sayfa1").Range("m6").Copy                      'şehir ismini kopyala
sat3 = Sheets("sayfa2").Cells(65536, "A").End(xlUp).Row + 1
Sheets("Sayfa2").Range("A" & sat3).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

Next: S2.Columns("B:C").AutoFit
End Sub

 

[muyat]

Yok mu yardımcı olacak

 

[numan şamil]

Merhaba
Kodunuz Çalışıyor
Siz galiba birleştirmeyi önceden manuel yaptınız
ufak bir eklenti ile kodunuzu denermisiniz

Sub Dikdörtgen1_Tıkla()
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
s1son = s1.Cells(Rows.Count, "N").End(3).Row
If s1son < 5 Then: MsgBox "Aktarılacak veri yok!", vbCritical: Exit Sub

s2sat = s2.Cells(Rows.Count, 2).End(3).Row + 1
Set ilkHucre = s2.Range("A" & s2sat)
For s1sat = 5 To s1son
    s2.Cells(s2sat, 1) = s1.Cells(s1sat, "M")
    s2.Cells(s2sat, 2) = s1.Cells(s1sat, "O") & " " & s1.Cells(s1sat, "P")
    s2.Cells(s2sat, 3) = s1.Cells(s1sat, "N")
    Set sonHucre = s2.Range("A" & s2sat)
    s2sat = s2sat + 1
Next:

Application.DisplayAlerts = False
With s2.Range(ilkHucre.Address & ":" & sonHucre.Address)
    .UnMerge
    .Merge
    .VerticalAlignment = xlCenter
End With
Application.DisplayAlerts = True
s2.Columns("B:C").AutoFit
End Sub