• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

D

denese

Katılım
17 Mart 2011
Mesajlar
441
Excel Vers. ve Dili
Office 2019
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.
 

Ekli dosyalar

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.
 
Ömer' Alıntı:
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.
Genişletmek için tıkla ...
Merhaba Ömer Bey,

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

Ekli dosyalar

Deneyiniz.
Kod: 
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
 
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.
 
Sorun değil. Deneyiniz. Klasördeki Excel kitabının adı "deneme" olarak yazıldı, siz kendinize göre uyarlarsınız.
Kod: 
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' Alıntı:
Sorun değil. Deneyiniz. Klasördeki Excel kitabının adı "deneme" olarak yazıldı, siz kendinize göre uyarlarsınız.
Kod: 
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
Genişletmek için tıkla ...
Ömer Bey, tam istediğim gibi oldu, çok teşekkür ediyorum. İyi çalışmalar.
 
Ö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.

219895 219894

Ö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.
 

Ekli dosyalar

Deneyiniz. Dosya yolu düzenlemelerini siz yaparsınız.
Kod: 
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
 
Ömer' Alıntı:
Deneyiniz. Dosya yolu düzenlemelerini siz yaparsınız.
Kod: 
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
Genişletmek için tıkla ...
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.

219911

Dediğim gibi, bazı durumları tecrübe etmeden bilemiyorum, öngöremiyorum. Konu uzadığı için tekrar kusura bakmayın.
 
Deneyiniz.
Not: detaylı deneme yapmadığım için gözden kaçırdığım nokta olabilir.
Kod: 
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
 
Ömer' Alıntı:
Deneyiniz.
Not: detaylı deneme yapmadığım için gözden kaçırdığım nokta olabilir.
Kod: 
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
Genişletmek için tıkla ...
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.
 
Rica ederim, iyi çalışmalar.
 
Ö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.
 
Merhaba,

Deneyiniz.
Kod: 
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,

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

Emeğinize sağlık, iyi çalışmalar.
 
Ömer' Alıntı:
Merhaba,

Deneyiniz.
Kod: 
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
Genişletmek için tıkla ...
Ö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.

221461

Tekrar yardımcı olabilir misiniz.

Saygılar, selamlar
 
Ömer Bey,

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

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

İyi çalışmalar
 

Ekli dosyalar

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' Alıntı:
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

.
Genişletmek için tıkla ...
Ömer Bey, tekrar çok teşekkür ediyorum, çok sağ olun. Saygılar, selamlar..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst