Satırları sütunlara aktarma

[Barons]

Merhabalar

Hastane isminde bir dosyam var ve burada Hastane isimleri var.Sorunum şu; Hastanelerin adresleri ve fax numaraları hep bir alt satırda yer alıyor.Bu adres ve fax metinlerini C ve D sütunlarına yan yana makro ile aktarmak istiyorum.
benzer sorun hatta daha karışık olanı disciler adlı sayfada.Buradada aralarda boşluklar ve kaymalar var.Bu 2 problemi makro ile çözmek istiyorum,,,yardımcı olacak arkadaşlara şimdiden teşekkürler...
Bu arada bu harika forumdan yaklaşık 1-1,5 yıldır uzak kaldım,özlemişim.
tekrar teşekkürler ,iyi çalışmalar

 

[Mahmut Kök]

Hastaneler sayfası için örnek kod.

Sub duzenle()
Set s1 = Sheets("hastaneler")
For a = 4 To s1.[a65536].End(3).Row Step 2
s1.Cells(a, "c") = s1.Cells(a + 1, "a")
s1.Cells(a, "d") = s1.Cells(a + 1, "b")
Next
b = s1.[a65536].End(3).Row
For a = 4 To b
If s1.Cells(a, "d") = Empty Then
s1.Rows(a).Delete
End If
b = s1.[a65536].End(3).Row
Next
End Sub

 

[Necdet]

Merhaba,

Bende hastaneler sayfasını yapmıştım.

Public Sub Hastane_Duzenle()
Application.ScreenUpdating = False
Sheets("hastaneler").Select
For i = [A65536].End(3).Row To 2 Step -2
    Cells(i - 1, "C") = Cells(i, "B")
    Cells(i - 1, "D") = Cells(i, "A")
    Rows(i).Delete
Next i
MsgBox "Düzenleme Bitmiştir..."
Application.ScreenUpdating = True
End Sub

Not : Çalıştırmadan önce sayfanın kopyasının çıkartılması iyi olur.

 

[Mahmut Kök]

dişçiler için örnek kod

Aşağıdaki kodu denemeden önce, Necdet Beyin uyarısını dikkate almanızı öneriyorum. Vediğim kod, sayfada düzenleme yapmıyor; sayfadaki verileri Sayfa3'e aktarıyor. İnşallah işinize yarar...

Sub dişçiler()
Set s1 = Sheets("disciler")
Set s2 = Sheets("Sayfa3")
For a = 2 To 702
If s1.Cells(a, "a") = Empty Then GoTo 3
sat = s2.Range("a65536").End(3).Row + 1
s2.Cells(sat, "a") = s1.Cells(a, "a")
z = 0
c = a + 6
For b = a + 1 To c
If s1.Cells(b, "a") <> Empty Then GoTo 2
If s1.Cells(b, "a") = Empty Then
z = z + 1
s2.Cells(sat, "b") = s2.Cells(sat, "b") & " " & s1.Cells(a + z, "b")
If s1.Cells(a + z, "d") = "Faks :" Then
s2.Cells(sat, "d") = s1.Cells(a + z, "e")
Else
If s2.Cells(sat, "c") <> Empty And s1.Cells(a + z, "e") <> Empty Then
s2.Cells(sat, "c") = s2.Cells(sat, "c") & " \ " & s1.Cells(a + z, "e")
End If
If s2.Cells(sat, "c") = Empty And s1.Cells(a + z, "e") <> Empty Then
s2.Cells(sat, "c") = s1.Cells(a + z, "e")
End If
End If
End If
Next b
2
3
Next a
End Sub

 

[Barons]

Çok teşekkürler
sorunum halloldu.

 

[Barons]

Muhteşem ...her ikiside halloldu...bu foruma ve yardımcı olan kardeşlerime çok teşekkürler...