Belirli sütun aralığındaki verileri, farklı bir sayfada alt alta listelemek/birleştirmek

[denese]

Merhaba Ömer Bey,

Benzer bir konuda daha değerli yardımlarınıza ihtiyaç duyuyorum. Ekteki örnekte, Data sayfasında yer alan çalışanların eş ve çocuk bilgilerini, Tablo sayfasındaki örnekte olduğu şekilde alt alta listelemek istiyorum.

Yardımlarınız için tekrar teşekkür ederim.

Saygılar.

 

[denese]

Merhaba Ömer Bey,

Yukarıdaki konuyu makro kullanmadan dolaylı yollardan çözüme kavuşturdum. Tüm yardımlarınız için tekrar teşekkür ederim.

Saygılar.

 

[denese]

Merhabalar,

18. mesajdaki örneğe çok benzer bir listelemeyle ilgili değerli desteklerinize ihtiyacım var. Detayları ekteki dosya üzerinde belirtim. Rica etsem yardımcı olabilir misiniz.

 

[Ömer]

Yeni açıklamalarınıza göre yazdım.
xlsx olarak yedek alıyor. Mesajda csv yazdığınız için belirttim.

Ödenek için;

Sub Odenek_Listele_Aktarim()

    If MsgBox("Odenek_Aktarim sayfasındaki tüm veriler 'C:\Dosyalar' adresine kaydedilecek. Devam edilsin mi?", vbYesNo + vbQuestion, " Uyarı ") = vbNo Then Exit Sub
   
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, j As Long, t As Byte
   
    Set Sc = Sheets("Ödenek_Aktarim")
    Set Sd = Sheets("Odenek_Data")
   
    yol = "C:\Dosyalar\"
    dosya = yol & "Odenek_Aktarim_" & Format(Now, "dd.mm.yyyy_hh.mm.ss") & ".xlsx"
   
    Application.ScreenUpdating = False
    Sc.Select
    Range("A2:D" & Rows.Count).Clear
   
    For i = 1 To Sd.Cells(1, Columns.Count).End(xlToLeft).Column Step 5
        sat = Sd.Cells(Rows.Count, i).End(xlUp).Row
        s = Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 2 To sat
            If Sd.Cells(j, i + 2) > 0 Then
                For t = 1 To 4
                    Cells(s, t) = Sd.Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
    Next i
   
    Sheets.Add.Name = "Odenek_Aktarim_"
    Sc.Range("A1:D" & s).Copy Range("A1")
    Cells.EntireColumn.AutoFit
   
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs Filename:=dosya
        .Close
    End With
   
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
   
    MsgBox "CSV aktarım dosyası oluşturuldu", vbInformation, "Bilgi"

End Sub

Kesinti için;

Sub Kesinti_Listele_Aktarim()

    If MsgBox("Kesinti_Aktarim sayfasındaki tüm veriler 'C:\Dosyalar' adresine kaydedilecek. Devam edilsin mi?", vbYesNo + vbQuestion, " Uyarı ") = vbNo Then Exit Sub
   
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, j As Long, t As Byte
   
    Set Sc = Sheets("Kesinti_Aktarim")
    Set Sd = Sheets("Kesinti_Data")
   
    yol = "C:\Dosyalar\"
    dosya = yol & "Kesinti_Aktarim_" & Format(Now, "dd.mm.yyyy_hh.mm.ss") & ".xlsx"
   
    Application.ScreenUpdating = False
    Sc.Select
    Range("A2:E" & Rows.Count).Clear
   
    For i = 1 To Sd.Cells(1, Columns.Count).End(xlToLeft).Column Step 6
        sat = Sd.Cells(Rows.Count, i).End(xlUp).Row
        s = Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 2 To sat
            If Sd.Cells(j, i + 4) > 0 Then
                For t = 1 To 5
                    Cells(s, t) = Sd.Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
    Next i
   
    Sheets.Add.Name = "Kesinti_Aktarim_"
    Sc.Range("A1:E" & s).Copy Range("A1")
    Cells.EntireColumn.AutoFit
   
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs Filename:=dosya
        .Close
    End With
   
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
   
    MsgBox "CSV aktarım dosyası oluşturuldu", vbInformation, "Bilgi"

End Sub

 

[denese]

Ömer Bey, sorunsuz listeliyor. Fakat sadece "C:\Dosyalar\" klasörüne kayıt yapsın istiyorum. Mevcut dosyadaki "Ödenek_Aktarim" sayfasına kayıt yapmasın. Bunun için kodda nasıl bir değişiklik yapmam gerekir.

 

[Ömer]

Ödenek aktarım;

Sub Odenek_Listele_Aktarim()

    If MsgBox("Odenek_Aktarim sayfasındaki tüm veriler 'C:\Dosyalar' adresine kaydedilecek. Devam edilsin mi?", vbYesNo + vbQuestion, " Uyarı ") = vbNo Then Exit Sub
    
    Dim Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, j As Long, t As Byte
    
    Set Sd = Sheets("Odenek_Data")
    
    yol = "C:\Dosyalar\"
    dosya = yol & "Odenek_Aktarim_" & Format(Now, "dd.mm.yyyy_hh.mm.ss") & ".xlsx"
    
    Application.ScreenUpdating = False
    
    Sheets.Add.Name = "Odenek_Aktarim_"
    Sd.Range("A1:D1").Copy Range("A1")
        
    For i = 1 To Sd.Cells(1, Columns.Count).End(xlToLeft).Column Step 5
        sat = Sd.Cells(Rows.Count, i).End(xlUp).Row
        s = Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 2 To sat
            If Sd.Cells(j, i + 2) > 0 Then
                For t = 1 To 4
                    Cells(s, t) = Sd.Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
    Next i
    
    Cells.EntireColumn.AutoFit
    
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs Filename:=dosya
        .Close
    End With
    
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    
    MsgBox "CSV aktarım dosyası oluşturuldu", vbInformation, "Bilgi"

End Sub

Kesinti aktarım;

Sub Kesinti_Listele_Aktarim()

    If MsgBox("Kesinti_Aktarim sayfasındaki tüm veriler 'C:\Dosyalar' adresine kaydedilecek. Devam edilsin mi?", vbYesNo + vbQuestion, " Uyarı ") = vbNo Then Exit Sub
    
    Dim Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, j As Long, t As Byte

    Set Sd = Sheets("Kesinti_Data")
    
    yol = "C:\Dosyalar\"
    dosya = yol & "Kesinti_Aktarim_" & Format(Now, "dd.mm.yyyy_hh.mm.ss") & ".xlsx"
    
    Application.ScreenUpdating = False
    
    Sheets.Add.Name = "Kesinti_Aktarim_"
    Sd.Range("A1:E1").Copy Range("A1")

    
    For i = 1 To Sd.Cells(1, Columns.Count).End(xlToLeft).Column Step 6
        sat = Sd.Cells(Rows.Count, i).End(xlUp).Row
        s = Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 2 To sat
            If Sd.Cells(j, i + 4) > 0 Then
                For t = 1 To 5
                    Cells(s, t) = Sd.Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
    Next i
    
    Cells.EntireColumn.AutoFit
    
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs Filename:=dosya
        .Close
    End With
    
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    
    MsgBox "CSV aktarım dosyası oluşturuldu", vbInformation, "Bilgi"

End Sub

 

[denese]

Ömer Bey, ne kadar teşekkür etsem az. Beni yine büyük bir dertten kurtardınız. Çok teşekkür ederim.