Satırdaki malzeme verilerini alt alta yazdırma

[bilalakdeniz]

Satıra girilen malzemeleri, diğer sayfada alt altta yazdırmak istiyorum,

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Y As Byte, Z As Byte
    Dim SATIR As Integer, SAY As Integer
 
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("ÇIKIŞ LİSTESİ")
 
    Application.ScreenUpdating = False
 
    S2.Rows("2:65536").Delete Shift:=xlUp
    SATIR = 2
 
    For X = 2 To S1.Range("A65536").End(3).Row
        If Trim(S1.Cells(X, "A")) <> "" Then
            S2.Range(S2.Cells(SATIR, "A"), S2.Cells(SATIR, "S")).Value = S1.Range(S1.Cells(X, "A"), S1.Cells(X, "S")).Value
 
            For Y = 20 To S1.Range("IV1").End(1).Column Step 8
                If S1.Cells(X, Y) > 0 And S1.Cells(X, Y) <> "" Then
                    S2.Range(S2.Cells(SATIR, "T"), S2.Cells(SATIR, "AA")).Value = S1.Range(S1.Cells(X, Y), S1.Cells(X, Y + 7)).Value
                    SATIR = SATIR + 1
                    SAY = SAY + 1
                End If
            Next
 
            If SAY > 1 Then
 
            For Z = 1 To 19
                With S2.Range(S2.Cells(S2.Cells(65536, "A").End(3).Row, Z), S2.Cells(S2.Cells(65536, "A").End(3).Row + SAY - 1, Z))
                    If Z = 4 Or Z = 6 Or Z = 7 Or Z = 10 Or Z = 12 Or Z = 13 Or Z = 16 Or Z = 17 Or Z = 18 Or Z = 19 Then
                    .HorizontalAlignment = xlGeneral
                    ElseIf Z = 15 Then
                    .HorizontalAlignment = xlLeft
                    Else
                    .HorizontalAlignment = xlCenter
                    End If
                    .VerticalAlignment = xlCenter
                    .WrapText = True
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With
            Next
 
            End If
 
            SAY = 0
 
        End If
    Next
 
    S2.Select
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[bilalakdeniz]

Korhan Bey çok teşekkür ederim. Çok güzel, Hücreleri birleştirmese her satıra ayrı ayrı yazdırabilirmiyiz.

 

[Korhan Ayhan]

Selamlar,

Siz örnek dosyanızda birleştirme işlemi yaptığınız için bende cevabımı bu şekilde verdim. Bu detayı sorunuzda belirtmeniz gerekirdi.

 

[bilalakdeniz]

Yeni konu olarakmı yazmam lazım. Çünkü firmaları süzdüğüm zaman sadece birinci satırını alıyor.

 

[bilalakdeniz]

Satıra girilen malzemeleri, diğer sayfada alt altta yazdırmak istiyorum,

Veri sayfasındaki malzeme lsitesini çıkış listesinde toplamak alt alta yazdırmak istiyorum.

 

[bilalakdeniz]

Korhan bey, yapmış olduğunuz makroyu son gönderdiğim dosyaya göre düzeltmeniz mümkünmü?