sütunlardaki verileri alt alta yazdırma makrosu

[gertt]

Merhaba.
D-E-F (Satır aralıkları 2-100 arası) sütunlarındaki verileri K sütununa (5. satırdan başlayacak) alt alta nasıl aktarabiliriz?
Teşekkürler.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub UcSutunTekSutuna()
    
    Dim i   As Long, _
        j   As Long, _
        k   As Integer
        
    j = Cells(Rows.Count, "K").End(3).Row
    If j < 5 Then j = 5
    
    Application.ScreenUpdating = False
    
    Range("K5:K" & j).ClearContents
    
    For k = 4 To 6
        i = Cells(Rows.Count, k).End(3).Row
        If i > 1 Then
            j = Cells(Rows.Count, "K").End(3).Row + 1
            If j < 5 Then j = 5
            Range(Cells(2, k), Cells(i, k)).SpecialCells(xlCellTypeConstants, 23).Copy Cells(j, "K")
        End If
    Next k
    
    Application.ScreenUpdating = True
    
    MsgBox "Hücreler Aktarılmıştır...", vbInformation, "N. YEŞERTENER"
    
End Sub

 

[gertt]

Necdet Bey,teşekkürler.
Sütunlarda veriler arasında (satırlarda) boşluklar varsa K sütununa aktarımda bu boşlukların olmamasını nasıl sağlayabiliriz?

 

[numan şamil]

Necdet Bey,teşekkürler.
Sütunlarda veriler arasında (satırlarda) boşluklar varsa K sütununa aktarımda bu boşlukların olmamasını nasıl sağlayabiliriz?

Necdet bey Müsadelerinizle
Alternatif olarak Korhan hocamdan derleme yaptığım kodları denermisiniz

Sub AKTAR()
    Dim Alan As Range, Satir As Integer
    
    Satir = 5
    
    Range("K5:K" & Rows.Count).ClearContents
    
    For Each Alan In Range("D2:D100,E2:E100,F2:F100")
     If Alan.Column = 4 Or Alan.Column = 5 Or Alan.Column = 6 Then
            If Alan.Offset(0, 0) <> "" Then
                Cells(Satir, "K") = Alan.Offset(0, 0).Value
                
                Satir = Satir + 1
            End If
        End If
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub[CODE]

[/CODE]

 

[gertt]

Numan Bey,teşekkürler.

 

[numan şamil]

Numan Bey,teşekkürler.

Kolay gelsin

 

[Necdet]

Merhaba,

2 numaralı mesajımı yeniden düzenledim.

 

[gertt]

Necdet Bey,tekrar teşekkür ederim.Zahmet verdim.

 

[DinTOR]

Buradaki örnek tüm satırları kopyalıyor ve aynı sayfanın K sütununa alt alta diziyor benim AK sütunu boştu oraya dizdirdim,

24. sütundan başlayarak 72. sütuna kadar olan sadece çift sayılıları başka bir sayfaya veya excel dosyasına nasıl dizdirebilirim?

Sizin kodlarınızdan düzeltme yaparak

Sub AKTAR()
    Dim Alan As Range, Satir As Integer
    
    Satir = 23
    
    Range("AK5:AK" & Rows.Count).ClearContents
    
    For Each Alan In Range("C23:C71,D23:D71,E23:E71")
     If Alan.Column = 4 Or Alan.Column = 5 Or Alan.Column = 6 Then
            If Alan.Offset(0, 0) <> "" Then
                Cells(Satir, "AK") = Alan.Offset(0, 0).Value
                
                Satir = Satir + 1
            End If
        End If
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub