• DİKKAT

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

klasördeki dosyalardan veri alma

  • Konbuyu başlatan Konbuyu başlatan rompla
  • Başlangıç tarihi Başlangıç tarihi
R

rompla

Katılım
24 Haziran 2010
Mesajlar
12
Excel Vers. ve Dili
2003, TR
Arkadaşlar;

Bir klasörde bulunan dosyalardan veri alma işini "Korhan AYHAN" arkadaşımızın kodunu değiştirerek aşağıdaki gibi yapmayı başardım en sonunda. Aslında bu benim için büyük bir adım. :) Ama çok amatörce oldu... Sorum şu bu kodu daha kullanılabilir hale nasıl getirebilirim?

KOD:

Option Explicit

Sub DOSYALARDAN_VERİ_AL()
Dim FSO As Object, DOSYA As Object, DOSYA_YOLU As Object, DOSYALAR As Object, SATIR As Long

Set FSO = CreateObject("Scripting.FileSystemObject")
Set DOSYA_YOLU = FSO.GetFolder(ThisWorkbook.Path)
Set DOSYALAR = DOSYA_YOLU.Files

Range("A:B").ClearContents

For Each DOSYA In DOSYALAR
If DOSYA.Name <> "RPR_2.xls" Then
SATIR = SATIR + 1

Range("A" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C1")
Range("B" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C2")
Range("C" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C3")
Range("D" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C4")
Range("E" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C5")
Range("F" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C6")
Range("G" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C7")
Range("H" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C8")
Range("I" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C9")
Range("J" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C10")
Range("K" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C10")
Range("L" & SATIR) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C12")

End If
Next

Set FSO = Nothing
Set DOSYA_YOLU = Nothing
Set DOSYALAR = Nothing
 
Ayrıca Korhan arkadaşımıza da çok teşekkür ediyorum bu kod için...
 
Selamlar,

Önerdiğimiz kodların işinize yaradığına sevindim. Aşağıdaki ifadeyle tam olarak ne kastettiniz?

... Sorum şu bu kodu daha kullanılabilir hale nasıl getirebilirim?
Genişletmek için tıkla ...
 
Korhan Ayhan' Alıntı:
Selamlar,

Önerdiğimiz kodların işinize yaradığına sevindim. Aşağıdaki ifadeyle tam olarak ne kastettiniz?
Genişletmek için tıkla ...

Özür diliyor ve soruma biraz daha açıklama getiriyorum...

Ben aslında klasördeki dosyalardan sadece 1 tek satırı kopyalıyorum. Bunu hücre hücre kopyalamak/aktarmak yerine bir döngü ile aktarsam daha iyi olmaz mı?? O zaman başlangıç hücresini ve bitiş hücresini girerim sadece. Herbir hücre için bir satır kod yazmama gerek kalmaz.
 
Selamlar,

Bu durumda aktarmak istediğiniz sütun bilgilerini vermeniz gerekiyor.
 
Selamlar,

Tabiki her hücre verisini almak için bir satır kod yazmak yerine döngü kullanabilirsiniz.

Kod: 
Option Explicit
 
Sub DOSYALARDAN_VERİ_AL()
    Dim FSO As Object, DOSYA As Object, DOSYA_YOLU As Object
    Dim DOSYALAR As Object, SATIR As Long, SÜTUN As Byte
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set DOSYA_YOLU = FSO.GetFolder(ThisWorkbook.Path)
    Set DOSYALAR = DOSYA_YOLU.Files
 
    Range("A:L").ClearContents
 
    For Each DOSYA In DOSYALAR
        If DOSYA.Name <> "Rpr_2.xls" Then
            SATIR = SATIR + 1
            For SÜTUN = 1 To 12
                Cells(SATIR, SÜTUN) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R20C" & SÜTUN)
            Next
        End If
    Next
 
    Set FSO = Nothing
    Set DOSYA_YOLU = Nothing
    Set DOSYALAR = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan bey

üstteki makroyu dosyama uyarlayamadım. yardımcı olurmusunuz.
 

Ekli dosyalar

Selamlar,

Sn. abbasonline aşağıdaki kodu denermisiniz. Dosyaların tümü aynı klasörde olmalıdır.

Kod: 
Option Explicit
 
Sub DOSYALARDAN_VERİ_AL()
    Dim FSO As Object, DOSYA As Object, DOSYA_YOLU As Object
    Dim DOSYALAR As Object, SATIR As Long, SÜTUN As Byte
    Dim X As Long, SON_SATIR As Long, TARİH As Date, MALZEME_ADI As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set DOSYA_YOLU = FSO.GetFolder(ThisWorkbook.Path)
    Set DOSYALAR = DOSYA_YOLU.Files
    
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Sheets("Sayfa4")
        .Range("C8:J65536").Clear
        .Range("C8:C65536").NumberFormat = "m/d/yyyy"
        .Range("C8:D65536,I8:I65536").HorizontalAlignment = xlCenter
    
        If .Range("A1") = "" Then
            MsgBox "Lütfen ilk tarihi giriniz !", vbCritical
            .Range("A1").Select
            Application.ScreenUpdating = True
            Exit Sub
        End If
    
        If .Range("A2") = "" Then
            MsgBox "Lütfen son tarihi giriniz !", vbCritical
            .Range("A2").Select
            Application.ScreenUpdating = True
            Exit Sub
        End If
    
        If .Range("E6") = "" Then
            MsgBox "Lütfen malzeme adını giriniz !", vbCritical
            .Range("E6").Select
            Application.ScreenUpdating = True
            Exit Sub
        End If
    
        SATIR = 7
        
        For Each DOSYA In DOSYALAR
            If DOSYA.Name <> "deneme99.xls" Then
                SON_SATIR = ExecuteExcel4Macro("COUNTA('" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!C1)") + 5
                For X = 7 To SON_SATIR
                    TARİH = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R" & X & "C1")
                    MALZEME_ADI = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R" & X & "C3")
                    If TARİH >= .Range("A1") And TARİH <= .Range("A2") And MALZEME_ADI = .Range("E6") Then
                        SATIR = SATIR + 1
                        For SÜTUN = 3 To 10
                            Cells(SATIR, SÜTUN) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R" & X & "C" & SÜTUN - 2)
                        Next
                    End If
                Next
            End If
        Next
    End With
    
    Application.ScreenUpdating = True
    
    Set FSO = Nothing
    Set DOSYA_YOLU = Nothing
    Set DOSYALAR = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
makroyu çalıştırdığımda
Sub DOSYALARDAN_VERİ_AL()

kısmı sarı renkte olup hata veriyor.
 
Selamlar,

Aynı prosedürden sadece bir adet kullanabilirsiniz. Uyguladığınız dosyada aynı isimde bir makro daha var. Onu silmelisiniz. Ya da adını değiştirmelisiniz.
 
Korhan bey

ben bir türlü Kitab1 adlı kitabcıktan, aynı klasör içinde olmasına rağmen veri alamadım, yardımcı olabilirmisiniz. dosyayı ekliyorum
 

Ekli dosyalar

Selamlar,

Kodu kendinize uyarlarken gereksiz karakterler oluşmuş. Bundan dolayı hata alıyorsunuz. Aşağıda kırmızı renkle belirttiğim bölümü silip deneyiniz.

Kod: 
End Sub[COLOR=red]__________________[/COLOR]
 
Korhan bey en sonunda çalıştırdım, ancak sadece BAŞLIK3 ün üzerine yazdığımı bulup getiriyor, BAŞLIK5 in üzerine örneğin cümlenin içinde geçen KUŞ kelimesini yazdığımda lütfen malzeme adını giriniz, diyor. BAŞLIK3 hariç diğerleride hep aynı.

Birde büyük küçük harfe duyarsız olurmu,
 
Selamlar,

Örnek dosyanızı incelerken içindeki açıklamaya dikkat ettim. 35000 satıra kadar veriler devam ediyor diye belirtmişsiniz.

Eğer yanlış bilmiyorsam "ExecuteExcel4Macro" özelliği ile bu kadar satırı sorgulayamazsınız. Zaten sorgulasa bile bu kadar satırdan sonuç elde etmek çok zaman alacaktır.

Benim tavsiyem forumdaki ADO (Kapalı Dosya İşlemleri) konularını incelemeniz olacaktır. Daha hızlı sonuçlar elde edebilirsiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst