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

[denese]

Merhaba,

Bir sayfada, her 7 sütundan sonra 1 sütun boşluk bırakılarak oluşturulan listeler yer alıyor. 7' şer sütundan oluşan bu listeleri, makro ile başka bir sayfada alt alta getirerek birleştirmek/listelemek istiyorum. Ekteki dosya üzerinde açıklama ve örnekleme yaptım.

Yardımcı olabilirseniz çok sevinirim.

 

[Ömer]

Merhaba,

CS sütunundan sonra sütun sayıları 1 eksiliyor. Bu durumda 7 sütun tezi geçerli olmuyor. İnceleyip konuyu açıklarsanız o şekilde ilerleyelim.

 

[denese]

Merhaba,

CS sütunundan sonra sütun sayıları 1 eksiliyor. Bu durumda 7 sütun tezi geçerli olmuyor. İnceleyip konuyu açıklarsanız o şekilde ilerleyelim.

Merhaba Ömer Bey,

Özür dilerim, hatalı olmuş. CS sütunundan sonra sütun sayıları 1 eksilmeyecek şekilde dosyayı revize ettim.

 

[Ömer]

Deneyiniz.

Sub listele()
    
    Dim Sc As Worksheet, Si As Worksheet, i As Integer, sat As Long, s As Long
    
    Set Sc = Sheets("CSV")
    Set Si = Sheets("Liste")
    
    Application.ScreenUpdating = False
    Sc.Select
    Si.Range("A:G").Clear

    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
        sat = Cells(Rows.Count, i).End(xlUp).Row
        s = Si.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(1, i).Resize(sat, 7).Copy Si.Cells(s, "A")
        i = i + 1
    Next i
    Si.Rows(1).Delete
        
End Sub

 

[denese]

Kod harika çalışıyor ve çok hızlı. Bir ricam daha olabilir mi? Listeleme işlemini aynı çalışma kitabında "Liste" sayfasına değil de, farklı bir çalışma kitabı oluşturarak belirli bir konuma, hücre biçimi ve formülleriyle birlikte değil de sadece değerleri yapıştırarak kaydettirebilir miyiz. Örneğin C:\Dosyalar klasörüne.

Kurguyu yaparken düşünemediğim bazı durumlar çıkıyor. Bunları da uygulamaya geçmeden fark edemiyorum. Kusura bakmayın lütfen.

 

[Ömer]

Sorun değil. Deneyiniz. Klasördeki Excel kitabının adı "deneme" olarak yazıldı, siz kendinize göre uyarlarsınız.

Sub listele()
    
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String
    
    Set Sc = Sheets("CSV")
    yol = "C:\Dosyalar\"
    dosya = "deneme.xlsx"
    
    Application.ScreenUpdating = False
    Sc.Select
    GetObject (yol & dosya)
    Set Sd = Workbooks(dosya).Worksheets("Sayfa1")
    Sd.Range("A:G").ClearContents

    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
        sat = Cells(Rows.Count, i).End(xlUp).Row
        s = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(1, i).Resize(sat, 7).Copy
        Sd.Cells(s, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        i = i + 1
    Next i
    Sd.Rows(1).Delete
    Windows(dosya).Visible = True
    Workbooks(dosya).Save
    Workbooks(dosya).Close
    
End Sub

 

[denese]

Sorun değil. Deneyiniz. Klasördeki Excel kitabının adı "deneme" olarak yazıldı, siz kendinize göre uyarlarsınız.

Sub listele()
   
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String
   
    Set Sc = Sheets("CSV")
    yol = "C:\Dosyalar\"
    dosya = "deneme.xlsx"
   
    Application.ScreenUpdating = False
    Sc.Select
    GetObject (yol & dosya)
    Set Sd = Workbooks(dosya).Worksheets("Sayfa1")
    Sd.Range("A:G").ClearContents

    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
        sat = Cells(Rows.Count, i).End(xlUp).Row
        s = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(1, i).Resize(sat, 7).Copy
        Sd.Cells(s, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        i = i + 1
    Next i
    Sd.Rows(1).Delete
    Windows(dosya).Visible = True
    Workbooks(dosya).Save
    Workbooks(dosya).Close
   
End Sub

Ömer Bey, tam istediğim gibi oldu, çok teşekkür ediyorum. İyi çalışmalar.

 

[denese]

Ömer Bey tekrar merhaba,

Şöyle bir şeye daha ihtiyaç duyuyorum. Oluşturduğumuz bu dosya, ücret bordrolarını oluşturmak için, puantaj verilerini sisteme toplu olarak aktarım yapmamızı sağlayan dosya biçimidir. Kullandığımız sistem, sıfır olan değerleri içeri yüklemeden işlem yapmamıza elverişli. Dolayısıyla dosyanın mevcut halinin bordro sistemine aktarım işlemi bir hayli zaman aldı.

Bu nedenle dosyayı oluştururken şöyle bir koşul ekleyebilir miyiz?

Her listenin 3. ve 5. sütunundaki veriyi toplasın ve eğer sonuç 0' a eşit ise, oluşturulan listeye, listenin sütun aralığını eklemesin.



Örneğin;

C3+E3=0 olduğu için, A3:G3 aralığını, (bu aralık satır ve sütun numaralarıyla da belirtilebilir)
MA2+MC2=0 olduğu için, LY2:ME2 aralığını, (bu aralık satır ve sütun numaralarıyla da belirtilebilir)

ve bunun gibi yan yana olan diğer listeleri de sorgulayıp, oluşturduğumuz listeye eklemesin.

Tekrar yardımcı olabilir misiniz.

 

[Ömer]

Deneyiniz. Dosya yolu düzenlemelerini siz yaparsınız.

Sub listele()
    
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, t As Byte
    
    Set Sc = Sheets("CSV")
    yol = "C:\Dosyalar\"
    dosya = "deneme.xlsx"
    
    Application.ScreenUpdating = False
    Sc.Select
    GetObject (yol & dosya)
    Set Sd = Workbooks(dosya).Worksheets("Sayfa1")
    Sd.Range("A:G").ClearContents

    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
        sat = Cells(Rows.Count, i).End(xlUp).Row
        s = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 1 To sat
            If Cells(j, i + 2) + Cells(j, i + 4) > 0 Then
                For t = 1 To 7
                    Sd.Cells(s, t) = Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
        i = i + 1
    Next i
    
    Sd.Rows(1).Delete
    Windows(dosya).Visible = True
    Workbooks(dosya).Save
    Workbooks(dosya).Close
    
End Sub

 

[denese]

Deneyiniz. Dosya yolu düzenlemelerini siz yaparsınız.

Sub listele()
   
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, t As Byte
   
    Set Sc = Sheets("CSV")
    yol = "C:\Dosyalar\"
    dosya = "deneme.xlsx"
   
    Application.ScreenUpdating = False
    Sc.Select
    GetObject (yol & dosya)
    Set Sd = Workbooks(dosya).Worksheets("Sayfa1")
    Sd.Range("A:G").ClearContents

    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
        sat = Cells(Rows.Count, i).End(xlUp).Row
        s = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 1 To sat
            If Cells(j, i + 2) + Cells(j, i + 4) > 0 Then
                For t = 1 To 7
                    Sd.Cells(s, t) = Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
        i = i + 1
    Next i
   
    Sd.Rows(1).Delete
    Windows(dosya).Visible = True
    Workbooks(dosya).Save
    Workbooks(dosya).Close
   
End Sub

Kod sorunsuz çalışıyor tekrar çok teşekkür ediyorum Ömer Bey. CSV safyasında sağdan sola sıralı olan 7' şer sütunluk listelerde, eğer herhangi bir sicilde değer yoksa, oluşturduğumuz deneme dosyasında aşağıdaki şekilde, sadece o liste grubunun başlığı yer alıyor. Eğer bu şekilde listelerdeki tüm sicillerin karşılığı "0" ise, liste başlığının da oluşturulan dosyaya gelememesini sağlayabilir miyiz.



Dediğim gibi, bazı durumları tecrübe etmeden bilemiyorum, öngöremiyorum. Konu uzadığı için tekrar kusura bakmayın.

 

[Ömer]

Deneyiniz.
Not: detaylı deneme yapmadığım için gözden kaçırdığım nokta olabilir.

Sub listele()
    
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, t As Byte, a As Long
    
    Set Sc = Sheets("CSV")
    yol = "C:\Dosyalar\"
    dosya = "deneme.xlsx"
    
    Application.ScreenUpdating = False
    Sc.Select
    GetObject (yol & dosya)
    Set Sd = Workbooks(dosya).Worksheets("Sayfa1")
    Sd.Range("A:G").ClearContents

    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
        sat = Cells(Rows.Count, i).End(xlUp).Row
        s = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 1 To sat
            If Cells(j, i + 2) + Cells(j, i + 4) > 0 Then
                a = a + 1
                For t = 1 To 7
                    Sd.Cells(s, t) = Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
        If a = 1 Then Sd.Rows(s - 1).Delete
        i = i + 1: a = 0
    Next i
    
    Sd.Rows(1).Delete
    Windows(dosya).Visible = True
    Workbooks(dosya).Save
    Workbooks(dosya).Close
    
End Sub

 

[denese]

Deneyiniz.
Not: detaylı deneme yapmadığım için gözden kaçırdığım nokta olabilir.

Sub listele()
   
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, t As Byte, a As Long
   
    Set Sc = Sheets("CSV")
    yol = "C:\Dosyalar\"
    dosya = "deneme.xlsx"
   
    Application.ScreenUpdating = False
    Sc.Select
    GetObject (yol & dosya)
    Set Sd = Workbooks(dosya).Worksheets("Sayfa1")
    Sd.Range("A:G").ClearContents

    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
        sat = Cells(Rows.Count, i).End(xlUp).Row
        s = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 1 To sat
            If Cells(j, i + 2) + Cells(j, i + 4) > 0 Then
                a = a + 1
                For t = 1 To 7
                    Sd.Cells(s, t) = Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
        If a = 1 Then Sd.Rows(s - 1).Delete
        i = i + 1: a = 0
    Next i
   
    Sd.Rows(1).Delete
    Windows(dosya).Visible = True
    Workbooks(dosya).Save
    Workbooks(dosya).Close
   
End Sub

Hızlıca baktım, sorunsuz çalışıyor. Beni büyük bir iş yükünden kurtardınız Ömer Bey, tekrar çok teşekkür ederim.

 

[Ömer]

Rica ederim, iyi çalışmalar.

 

[denese]

Ömer Bey,

Sizden bir ricada daha bulunabilir miyim.. Yukarıdaki kod ile, C:\Dosyalar klasöründe yer alan deneme.xlsx dosyasına kayıt yapıyoruz. Yapmak istediğim; C:\Dosyalar klasöründe deneme.xlsx dosyası bulundurmaya gerek olmaksızın, makroyu her çalıştırdığımda dosyayı yine aynı klasöre gg.aa.yyyy-ss.dd.nn adıyla farklı kaydetmek.

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

 

[Ömer]

Merhaba,

Deneyiniz.

Sub listele()
    
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, t As Byte, a As Long
    
    Set Sc = Sheets("CSV")
    yol = "C:\Dosyalar\"
    dosya = yol & Format(Now, "dd.mm.yy_hh.mm.ss") & ".xlsx"
    
    Application.ScreenUpdating = False
    Sheets.Add.Name = "XXX"
    Sc.Select

    Set Sd = Sheets("XXX")

    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
        sat = Cells(Rows.Count, i).End(xlUp).Row
        s = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 1 To sat
            If Cells(j, i + 2) + Cells(j, i + 4) > 0 Then
                a = a + 1
                For t = 1 To 7
                    Sd.Cells(s, t) = Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
        If a = 1 Then Sd.Rows(s - 1).Delete
        i = i + 1: a = 0
    Next i
    
    Sd.Select
    Rows(1).Delete
    
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs Filename:=dosya
        .Close
    End With
    
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    
End Sub

 

[denese]

Ömer Bey,

İlginiz ve desteğiniz için ne desem ne kadar teşekkür etsem az.

Emeğinize sağlık, iyi çalışmalar.

 

[denese]

Merhaba,

Deneyiniz.

Sub listele()
   
    Dim Sc As Worksheet, Sd As Worksheet, i As Integer, sat As Long, s As Long
    Dim yol As String, dosya As String, t As Byte, a As Long
   
    Set Sc = Sheets("CSV")
    yol = "C:\Dosyalar\"
    dosya = yol & Format(Now, "dd.mm.yy_hh.mm.ss") & ".xlsx"
   
    Application.ScreenUpdating = False
    Sheets.Add.Name = "XXX"
    Sc.Select

    Set Sd = Sheets("XXX")

    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
        sat = Cells(Rows.Count, i).End(xlUp).Row
        s = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
        For j = 1 To sat
            If Cells(j, i + 2) + Cells(j, i + 4) > 0 Then
                a = a + 1
                For t = 1 To 7
                    Sd.Cells(s, t) = Cells(j, i + t - 1)
                Next t
                s = s + 1
            End If
        Next j
        If a = 1 Then Sd.Rows(s - 1).Delete
        i = i + 1: a = 0
    Next i
   
    Sd.Select
    Rows(1).Delete
   
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs Filename:=dosya
        .Close
    End With
   
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
   
End Sub

Ömer Bey tekrar merhaba,

Mevcut koda bir kriter daha ekleyebilir miyiz. Mevcut kodda her listenin 3. ve 5. sütunundaki veriyi toplasın ve eğer sonuç 0' a eşit ise, oluşturulan listeye, listenin sütun aralığını eklemesin demiştik.

Şimdi yapmak istediğim; her listenin 3. 5. ve 8. sütunundaki veriyi toplasın ve eğer sonuç 0' a eşit ise, oluşturulan listeye, listenin sütun aralığını eklemesin istiyorum.



Tekrar yardımcı olabilir misiniz.

Saygılar, selamlar

 

[denese]

Ömer Bey,

Konuyu biraz daha anlaşılır kılmak için tekrar açıklama yapmak istedim.


Örnek uygulama dosyası ekte yer alıyor. Yardımcı olabilirseniz çok sevinirim.

İyi çalışmalar

 

[Ömer]

Merhaba,

If Cells(j, i + 2) + Cells(j, i + 4) > 0 Then yerine aşağıdaki satırı yazarak deneyiniz.

If Cells(j, i + 2) + Cells(j, i + 4) + Val(Cells(j, i + 7)) > 0 Then

.

 

[denese]

Merhaba,

If Cells(j, i + 2) + Cells(j, i + 4) > 0 Then yerine aşağıdaki satırı yazarak deneyiniz.

If Cells(j, i + 2) + Cells(j, i + 4) + Val(Cells(j, i + 7)) > 0 Then

.

Ömer Bey, tekrar çok teşekkür ediyorum, çok sağ olun. Saygılar, selamlar..