Alt Alta Olan Satırları Tek Bir Satırda Toplama

[ottoman71]

Arkadaşlar merhaba,
Ekteki dosyadaki, alt alta olan satırları en üst satıra makro ile nasıl taşıyabiliriz.

A sütunda listeye ait rapor numaraları bulunmaktadır. B sütununda ise rapor numaralarına ait açıklamalar bulunmaktadır.

Elimizde olan sabit değerler ise; A sütunun sadece rakamdan oluşmasıdır.

Makro ile yapılması istenilen olay ise; Rapor numarasının altındaki boş satırları, tanıyıp, yandaki (B sütunundaki) açıklamaları Rapor numarasının hizasındaki hücreye taşımaktır.

Yardımcı olabilir misiniz lütfen.
Bu listeler ile her zaman uğraşıyorum ve çok vaktimi alıyor. Bunun için daha önceden aşağıdaki kodu kullanıyorum fakat bunda da sürekli satırları seçmek sorunda kalıyorum. Bu şekilde binlerce satırdan oluşan listeler çıkıyor.

Sub birlestir()
Dim alan As Range
[g1] = Empty
For Each alan In Selection
[g1] = [g1] & " " & alan.Value & Chr(10)
Next
Selection.Value = [g1]
[g1] = Empty
End Sub

 

[ottoman71]

Arkadaşlar yardım edecek kimse yok mu?

 

[Ergün Güler]

Arkadaşlar yardım edecek kimse yok mu?

Selam,
dosyanız ektedir. İnceleyiniz.

Sub aktar()
Dim md As Worksheet
Dim s1 As Worksheet

Set md = Sheets("Mevcut Durum")
Set s1 = Sheets("Olması Gereken")

son = md.Range("B65536").End(3).Row
sat = 1
'deg = Empty
Application.ScreenUpdating = False

s1.Range("A2:F65536").ClearContents

For i = 2 To son

If md.Cells(i, "A") <> "" Then
sat = sat + 1
s1.Cells(sat, "A") = md.Cells(i, "A")
s1.Cells(sat, "C") = md.Cells(i, "C")
s1.Cells(sat, "D") = md.Cells(i, "D")
s1.Cells(sat, "E") = md.Cells(i, "E")
s1.Cells(sat, "F") = md.Cells(i, "F")
deg = Empty
deg = md.Cells(i, "B")
GoTo git
End If

deg = deg & Chr(10) & md.Cells(i, "B")
s1.Cells(sat, "B") = deg

git:
Next

Application.ScreenUpdating = False

MsgBox """" & md.Name & """ Sayfasından, " & vbLf & "" & s1.Name & """ Sayfasına" _
& vbLf & "Aktarma İşlemi Tamamlanmıştır", vbInformation, "AKTARMA İŞLEMİ"

End Sub

 

[ottoman71]

Ergün Hocam,Allah ne muradınız varsa versin
Çok teşekkür ederim ellerinize sağlık.

 

[Ergün Güler]

Ergün Hocam,Allah ne muradınız varsa versin
Çok teşekkür ederim ellerinize sağlık.

selam,
Ben de çok teşekkür ederim. Çözüm bulmanıza sevindim.
kodları duruyor. ekli dosyayı kaldırdım.

İyi çalışmalar.

 

[ottoman71]

selam,
Ben de çok teşekkür ederim. Çözüm bulmanıza sevindim.
kodları duruyor. ekli dosyayı kaldırdım.

İyi çalışmalar.

Teşekkür ederim. İşimi gördü. Tekrar ellerinize sağlık