Tüm sayfalardaki bilgileri tek bir sütunda alt alta yazdırma

[maxcilopez]

Merhaba arkadaşlar elimde böyle bir kod var bu kod aktif olan sayfadaki bilgileri isteğim şekilde BO Sütununa alt alta yazıyor. Fakat benim 5-6 adet sayfam var ve ben bu makroyu her sayfada ayrı ayrı çalıştırmak istemiyorum.
Bu yüzden makroyu çalıştırdığımda sadece ilk sayfadaki BO sutununa önce 1. sayfadaki bilgileri satır satır yazmasını, daha sonra ikinci sayfadaki bilgileri tekrar 1. sayfadaki BO sütununda en son kaldığı satırdan devam ederek yazmasını istiyorum .3....4...5... sayfalarda dahil vs

Sub BirlestirYaz()
x = 1
For h = 4 To 62
For i = Range("c69").End(3).Row To 1 Step -1
    For j = i - 1 To 1 Step -1
If Cells(i, h) <> "" Then
If Cells(j, h) <> "" Then
If Cells(i, h) <> "" Then
Cells(x, "bo") = Cells(i, 3).Text & ":" & Cells(i, h).Text & " " & Cells(j, 3).Text & ":" & Cells(j, h).Text
x = x + 1
Exit For
End If
End If
End If
Next
Next
Next
MsgBox "Bitti..."
End Sub

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub BirlestirYaz()
    Dim S1 As Worksheet
    Set S1 = Sheets(1)
    x = 1
    For Each Sayfa In ThisWorkbook.Worksheets
        With Sayfa
            For h = 4 To 62
                For i = .Range("c69").End(3).Row To 1 Step -1
                    For j = i - 1 To 1 Step -1
                        If .Cells(i, h) <> "" Then
                            If .Cells(j, h) <> "" Then
                                If .Cells(i, h) <> "" Then
                                    S1.Cells(x, "bo") = .Cells(i, 3).Text & ":" & .Cells(i, h).Text & " " & .Cells(j, 3).Text & ":" & .Cells(j, h).Text
                                    x = x + 1
                                    Exit For
                                End If
                            End If
                        End If
                    Next
                Next
            Next
        End With
    Next
    MsgBox "Bitti..."
End Sub

 

[maxcilopez]

Allah senden razı olsun. Senden bir yardım daha isteyeceğim.
Peki bu BO sutununa yazdığı yazıları aynı zamanda E:\proje.cvs isimli dosya oluşturup bu dosyanın içerisine de alt alta yazmasını nasıl sağlarım.

 

[Korhan Ayhan]

Merhaba,

Kodun son satırına aşağıdaki kodu ilave edip deneyin.

    ActiveWorkbook.SaveAs Filename:="E:\proje.csv", FileFormat:=xlCSV, CreateBackup:=False

 

[maxcilopez]

ilgin için teşekürler dostum fakat olmadı!
Verdiğin kod sayfa 1 i komple yazdı ben ise sadece bo sutununu yazdırmak istiyorum

 

[Korhan Ayhan]

Aşağıdaki kodları ekleyip deneyiniz.

    Range("BO:BO").Copy
    Set K1 = Workbooks.Add(1)
    K1.Sheets(1).Range("A1").PasteSpecial
    K1.SaveAs Filename:="E:\proje.csv", FileFormat:=xlCSV, CreateBackup:=False

 

[maxcilopez]

Sağol Allah razı olsun