• DİKKAT

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

tüm sayfaların son satırlarını yeni sayfada listelemek

E

elktronom

Katılım
20 Şubat 2010
Mesajlar
12
Excel Vers. ve Dili
office 2007
Merhabalar sayın hocalarım çok araştırdım fakar bulamadım.
321 adet çalışma kitabım var. Her biri 18 (R ye kadar) sütündan oluşuyor. Çalışma kitaplarının satır sayıları farklı farklı. Bu çalışma kitaplarının her birinin son satırlarını komple 18 sütün olarak başka bir çalışma kitabında listelemem gerekiyor. Şimdiden teşekürler iyi çalışmalar.
 
Selamlar,

Forumumuza hoşgeldiniz. Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub SAYFALARDAKİ_SON_SATIRLARI_LİSTELE()
    Dim SAYFA As Worksheet, SATIR As Long, SON_SATIR As Long
 
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("RAPOR").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
 
    Sheets.Add Before:=Sheets(1)
    ActiveSheet.Name = "RAPOR"
    SATIR = 2
 
    For Each SAYFA In ThisWorkbook.Worksheets
        If SAYFA.Name <> "RAPOR" Then
            SON_SATIR = SAYFA.Range("A65536").End(3).Row
            SAYFA.Range("A" & SON_SATIR & ":R" & SON_SATIR).Copy Sheets("RAPOR").Cells(SATIR, "A")
            SATIR = SATIR + 1
        End If
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
A. Selam Korhan Bey ilginize teşekkürler,
Kodunuzu denedim elinize sağlık çok kullanışlı olmuş fakat benim tam olarak yeni bir dosyada, bir kodla bu 321 dosyanın olduğu klasörü gösterip, kodun her dosyayı açıp son satırını alıp benim yeni dosyamda alt alta dizmesini istiyorum. teşekkürler
 
Selamlar,

Bu dosyaların içindeki hangi sayfadan bilgiler alınacak? Bilgi alınacak sayfanın isimleri her dosyada aynımı?
 
Selamlar,

Boş bir excel dosyasına boş bir modül ekleyin. Aşağıdaki kodu bu modüle aktarıp dosyanızı ANA_DOSYA adıyla kayıt edin. Daha sonra kodu çalıştırın.

Kod: 
Option Explicit
 
Sub KLASÖR_ALTINDAKİ_DOSYALARDAN_VERİ_AL()
    Dim KLASÖR As Object, DOSYA_YOLU As String, DOSYALAR As Object, DOSYA As Object
    Dim SATIR As Long, SON_SATIR As Long, BUL As Range, ADRES As String
 
    Set KLASÖR = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
    If Not KLASÖR Is Nothing Then
        DOSYA_YOLU = KLASÖR.SELF.Path & "\"
    Else
        MsgBox "İşleme devam edebilmeniz için klasör seçimi yapmalısınız !", vbCritical
        Exit Sub
    End If
    Application.ScreenUpdating = False
 
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("RAPOR").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
 
    Sheets.Add Before:=Sheets(1)
    ActiveSheet.Name = "RAPOR"
    SATIR = 2
 
    Set DOSYALAR = CreateObject("Scripting.FileSystemObject").GetFolder(DOSYA_YOLU).Files
 
    For Each DOSYA In DOSYALAR
        If InStr(DOSYA.Type, "Excel") > 0 Then
            If UCase(Split(DOSYA.Name, ".")(0)) <> "ANA_DOSYA" Then
                Workbooks.Open Filename:=DOSYA
                Sheets("RaporAdresBileseni").Select
                SON_SATIR = Range("O65536").End(3).Row
 
                If SON_SATIR <= 8 Then GoTo Devam
 
                If WorksheetFunction.CountIf(Range("O:O"), 1) = 1 Then
                    Range("A" & SON_SATIR & ":R" & SON_SATIR).Copy ThisWorkbook.Sheets("RAPOR").Cells(SATIR, "A")
                    SATIR = SATIR + 1
                Else
                    Set BUL = Range("O9:O" & SON_SATIR).Find(1, LookAt:=xlWhole)
                    If Not BUL Is Nothing Then
                        ADRES = BUL.Address
                        Do
                            If BUL.Row > 9 Then
                                Range("A" & BUL.Row - 1 & ":R" & BUL.Row - 1).Copy ThisWorkbook.Sheets("RAPOR").Cells(SATIR, "A")
                                SATIR = SATIR + 1
                            End If
                        Set BUL = Range("O9:O" & SON_SATIR).FindNext(BUL)
                        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                    End If
 
                    Range("A" & SON_SATIR & ":R" & SON_SATIR).Copy ThisWorkbook.Sheets("RAPOR").Cells(SATIR, "A")
                End If
 
Devam:
                ActiveWorkbook.Close True
            End If
        End If
    Next
 
    Set BUL = Nothing
    Set DOSYALAR = Nothing
    Set KLASÖR = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Bey Merhabalar,

Öncelikle kod ve ilginiz için çok teşekkür ederim, dediğinizi yaptım ANA_DOSYA isimli bir dosya oluşturup yolu gösterdim hata verdi, daha sonra kodun içindeki xls yazan yerleri xlsx yapıp denedim bu seferde kodu çalıştırıp klasörü gösterdiğimde direk işleminiz tamamlanmıştır diyor. Acaba nasıl çözebiliriz
 
rapor adres yazan yeri raporadresbileşeni yaptım başka dosyalarda denedim kod çalıştı benim dosyalarımda mı sıkıntı var acaba
 

Ekli dosyalar

Selamlar,

Eklemiş olduğunuz dosyada bir problem gözükmüyor. Benim önerdiğim kod "A" sütunundaki dolu hücrelere bakarak çalışmaktadır. Eklediğiniz dosyada "A" sütununda veri yokmuş gibi görünüyor. Eğer asıl dosyalarınızda da durum böyle ise bundan dolayı kod çalışmıyor olabilir.
 
merhaba Korhan Bey,

Diğer dosyalarda a sutununda veri olduğu halde yinede almıyor, ayrıca yanlızca A sütünü değil R ye kadar tüm sütünların son satırını almalıyız.
 
Selamlar,

İşyerinde 2003 versiyon var denemeyi ancak akşam evden yapabilirim.
 
İlginize gerçekten çok teşekkürler Korhan Bey sağolun
 
Korhan Bey şimdi gözüme takıldı benim dosyaların 2. satırındaki sütünlar A'dan H'ye kadar birleşik acaba kod ondan çalışmıyor olabilir mi? Size gönderdiğim örnek dosya da aynı şekilde birleşik ordan kendinizde bakabilirsiniz. Bana son satır olarak A'dan R'ye kadar lazım onu tekrar belirtiyim belki kodu yazarken yardımcı olur.
 
Korhan Bey yine ben :)

Herşey için çok teşekkür ederim kod tamamdır elinize sağlık :)
 
Selamlar Korhan Bey,

Başımda çok büyük bir sıkıntı daha var sizinde başını ağrıttım kusura bakmayın,

Sorun şu, bendeki dosyalardaki son satırı almamın amacı içerisindeki en büyük rakamın bulunduğu satırı komple almaktı. Fakat şöyle bir durum var bazı dosyalardaki sıralamalarda içinde birden fazla seri var. Yani mesela 1 den başlayıp 50 ye kadar gidiyor sonra yine başlayıp bu kez 23e kadar gidiyor tekrar başlayıp 70e kadar gidiyor. örnek bi dosya yüklüyorum tekrar bakarsanız çok sevinirim iyi çalışmalar. Dosyayı office 2003 olarak yüklüyorum.
 

Ekli dosyalar

Selamlar,

Üstteki mesajımdaki kodu hem 2003 versiyonda hemde 2007 versiyonda çalışacak şekilde revize ettim. İncelermisiniz.
 
Korhan Bey merhabalar,
kod için teşekkürler kodla bayağı bi uğraştım fakat kod bu seferde son satırları almıyor. Sanırım kodda dosya içindeki 1 olan satırı buldurup onun öncesini aldırıyorsunuz. Fakat bazı dosyalar mesela 1den başlayıp 25 e kadar gidiyor. Yani içinde sadece maksimum 25 var tekrar birden başlayıp mesela 50 ye kadar gitmiyor. işte kod bu 25 i almıyor çünkü bundan sonra 1 yok. Son satır 25 bunu nasıl çözebiliriz. Şimdiden teşekkürler.
 
Selamlar,

#6 nolu mesajımdaki kodu istekleriniz doğrultusunda güncelledim. İncelermisiniz.
 
Korhan Bey selamlar,
Kod için eşekkürler inceledim içinde sadece 1-25 olan dosyanın 25ini alıyor. 1-30 , 1-45, 1-60 olan dosyalarda 30 ve 45 i alıp 60ı almıyor. bence kod döngüye girdiğinde 30 ve 45'e 1den önce diye bakıyor fakat son satıra bakmıyor bi incelermisniz tekrar zahmet olmazsa
 
Selamlar,

Emin misiniz ?

Ben denediğimde tüm son satırları aktarıyor. Sonuç alamadığınız dosyayı eklerseniz kontrol edebiliriz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst