• DİKKAT

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

klasörde bulunan her dosyadan veri alma

  • Konbuyu başlatan Konbuyu başlatan desk
  • Başlangıç tarihi Başlangıç tarihi
D

desk

Katılım
17 Ekim 2005
Mesajlar
288
Excel Vers. ve Dili
excel 2010 türkçe
Mrb

Benim sorum diyelimki ahmet adında bir klasörün içinde bulunan bir sürü excel dosyası var excel dosyalarındaki verilerin mantığında hepsinde bakiye kısmı var ve ben bu bakiyeleri çektirmek istiyorum dosyaları tek tek bakiye kısımlarını göstererek liste alabilirim fakat benim yapmak istediğim ahmet klasörüne attığım her yeni dosyanın ismini ve bakiyesini listeye eklesin her dosyayı açtığımda klasörde bulunan tüm excel dosyalarını kontrol etsin ve isim ve bakiyelerini listelesin. Tek tek yaparsam her yeni dosya oluşturduğumda bu dosyanın adını formülle eklemem gerekecek bunun pratiğini öğrenebilirmiyim.

İlginiz için şimdiden tşk
 
Merhaba,

Sorunuzu örnek dosya(lar) ile desteklerseniz çözüme daha çabuk ulaşabilirsiniz.
 
dosya eklememe gerek varmı klasördeki 5 tane excel dosyasından iki sutün deki veriyi çektirmek her açtığımda klasörde 6 dosya olursa 6 dosya 7 dosya olursa 7 dosyaya bakıp listeleme yapması
 
Humm bu postu anlayamadım sanırım benim yapmak istediğimle alakalı değil yapmak istediğimi dosya olarak ekledim bakarmısınız üstadlar.
 

Ekli dosyalar

Bu mümkün değilmi üstadlar.?
 
Selamlar,

Ekteki örnek dosyayı incelermisiniz. B11 hücresine haftayı yazıp butona tıklayınız. Açıklama kısmında "ÜRETİM" yazan tüm veriler listelenecektir.

Kullanılan kod;

Kod: 
Option Explicit
 
Sub TÜM_VERİLERİ_AL()
    Dim Veri_Dosyası As Workbook, Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet
    Dim Dosya_Yolu As String, Hafta As Byte, Satır As Long
    Dim Bul As Range, Adres As String
 
    On Error GoTo Son
 
    Application.ScreenUpdating = False
 
    Set Veri_Dosyası = ThisWorkbook
 
    Dosya_Yolu = Veri_Dosyası.Path & "\MAMUL"
 
    Hafta = Veri_Dosyası.Sheets("Sayfa1").Range("B11")
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
 
    Veri_Dosyası.Sheets("Sayfa1").Range("A14:E65536").ClearContents
 
    Satır = Veri_Dosyası.Sheets("Sayfa1").Range("A65536").End(3).Row + 1
 
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
 
        Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 
        Set Bul = [B:B].Find(Hafta, LookAt:=xlWhole)
 
        If Not Bul Is Nothing Then
 
        Adres = Bul.Address
 
        Do
 
        If Cells(Bul.Row, 3) = "ÜRETİM" Then
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 1) = Cells(Bul.Row, 1)
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 2) = Replace(Kaynak_Dosya.Name, ".xls", "")
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 3) = Cells(Bul.Row, 2)
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 4) = Cells(Bul.Row, 3)
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 5) = Cells(Bul.Row, 4)
        Satır = Satır + 1
        End If
 
        Set Bul = [B:B].FindNext(Bul)
 
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
 
        Kaynak_Dosya.Close True
 
        End If
 
    Next
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub
 

Ekli dosyalar

Süpersin ..!!!

Veri_Dosyası.Sheets("Sayfa1").Range("A14:E65536").ClearContents

Satır = Veri_Dosyası.Sheets("Sayfa1").Range("A65536").End(3).Row + 1

veri alanını genişletmek istiyorum.

Alanın genişliği bölümü burası sanırım diyelimki bir dosyada 200üncü satıra kadar üretim yok 200 den sonra var nasıl büyütebilirim tarama alanını bu kısmı biraz açıklarmısınki genişletebileyim yapamadım.

Tek kelimeyle süpersin bunu tekrar söylemek istiyorum.! :)
 
üstad mamul dosyasının yanında birde mamül1 dosyasına ikisine birden baktırmak istiyorum virgülle çoğaltmayı denedim olmadı \mamul ü nasıl çoğaltabilirim. ayrıca bulamadığı dosyaları açıyor bulamadıklarını açmamasını nasıl sağlayabilirim araç çubuğuna bir sürü açılıyor nasıl engelleyibilir.
 
Selamlar,

Verileri aramaya yarayan satır aşağıdaki satırdır. Eklemiş olduğunuz dosyalarda hafta sütunu B sütunu olduğu için sadece [B:B] olarak ayarlanmıştır. Ayrıca tüm B sütununda arama yaptığı için alan genişletmesine gerek yoktur.

Kod: 
Set Bul = [B:B].Find(Hafta, LookAt:=xlWhole)

Aynı anda birden fazla klasörde arama yapması için kodu revize etmek gerekecektir.

Bütün dosyaları sırayla açarak arama yapmaktadır. Sonuçta işlem bittiğinde tüm dosyaların kapanması gerekir.
 
Dosya_Yolu = Veri_Dosyası.Path & "\MAMUL"
Dosya_Yolu = Veri_Dosyası.Path & "\MAMUL1"

şeklinde yaptığım zaman neden sonuç alamıyorum ikisinide aramazmı?

Ayrıca isterseniz deneyebilirsiniz sonuç bulamadıklarını kapatmıyor açık bırakıyor.
 
Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Kod: 
Option Explicit
 
Sub TÜM_VERİLERİ_AL()
    Dim İlk_Süre As Date, Son_Süre As Date, Toplam_Süre As Date
    Dim Klasör() As String, X As Integer
    Dim Veri_Dosyası As Workbook, Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet
    Dim Dosya_Yolu As String, Hafta As Byte, Satır As Long
    Dim Bul As Range, Adres As String
    
    On Error GoTo Son
    
    Application.ScreenUpdating = False
    
    İlk_Süre = Time
    
    Set Veri_Dosyası = ThisWorkbook
    
    If Veri_Dosyası.Sheets("Sayfa1").Range("C10") <> "" And Veri_Dosyası.Sheets("Sayfa1").Range("C11") <> "" Then
    
    Hafta = Veri_Dosyası.Sheets("Sayfa1").Range("C11")
    
    Klasör = Split(Veri_Dosyası.Sheets("Sayfa1").Range("C10"), ",")
    
    Veri_Dosyası.Sheets("Sayfa1").Range("A14:E65536").ClearContents
    
    For X = 0 To UBound(Klasör())
    
    Dosya_Yolu = Veri_Dosyası.Path & "\" & Klasör(X)
    
    If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
    
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
    
    Satır = Veri_Dosyası.Sheets("Sayfa1").Range("A65536").End(3).Row + 1
    
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
        
        Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
    
        Set Bul = [B:B].Find(Hafta, LookAt:=xlWhole)
        
        If Not Bul Is Nothing Then
        
        Adres = Bul.Address
        
        Do
        
        If Cells(Bul.Row, 3) = "ÜRETİM" Then
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 1) = Cells(Bul.Row, 1)
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 2) = Replace(Kaynak_Dosya.Name, ".xls", "")
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 3) = Cells(Bul.Row, 2)
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 4) = Cells(Bul.Row, 3)
        Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 5) = Cells(Bul.Row, 4)
        Satır = Satır + 1
        End If
                
        Set Bul = [B:B].FindNext(Bul)
        
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
        
        End If
    
        Kaynak_Dosya.Close True
    
    Next
    
    End If
    Next
    End If
    
    Son_Süre = Time
    
    Toplam_Süre = Format(Son_Süre - İlk_Süre, "hh:mm:ss")
    
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & "İşlem süresi ; " & Toplam_Süre, vbInformation
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub
 

Ekli dosyalar

İki kelime ile mükemmelsin,Süpersin tuttuğun altın olsun üstad...
 
Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 5) = Cells(Bul.Row, 4)

Bu satırdaki veriyi 10 ile çarptırıp yazdıramazmıyım?
 
Selamlar,

Aşağıdaki şekilde yazdırabilirsiniz.

Kod: 
Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, 5) = Cells(Bul.Row, 4) [B][COLOR=red]* 10[/COLOR][/B]
 
0,001 ile çarpmak istediğimde hata veriyor?
 
selamlar,
gönderdiğiniz dosyayı kendime uyarlamaya çalıştım ama beceremedim tabi ki:)
benim ihtiyacım olan şekliyle dosya ekledim. elinden gelip de dosyayı hazırlayabilen olursa çok sevinirim. şimdiden teşekkür ederim...
 

Ekli dosyalar

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Kullanılan kod;

Kod: 
Option Explicit
 
Sub TÜM_VERİLERİ_AL()
    Dim İlk_Süre As Date, Son_Süre As Date, Toplam_Süre As Date
    Dim Klasör() As String, X As Integer, Y As Long, Z As Integer
    Dim Veri_Dosyası As Workbook, Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet
    Dim Dosya_Yolu As String, Satır As Long, Sütun As Byte, Data() As String
    
    On Error GoTo Son
    
    Application.ScreenUpdating = False
    
    İlk_Süre = Time
    
    Set Veri_Dosyası = ThisWorkbook
    
    If Veri_Dosyası.Sheets("Sayfa1").Range("C10") <> "" Then
    
    Klasör = Split(Veri_Dosyası.Sheets("Sayfa1").Range("C10"), ",")
    
    Veri_Dosyası.Sheets("Sayfa1").Range("A14:N65536").ClearContents
    
    For X = 0 To UBound(Klasör())
    
    Dosya_Yolu = Veri_Dosyası.Path & "\" & Klasör(X)
    
    If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
    
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
    
    Satır = Veri_Dosyası.Sheets("Sayfa1").Range("A65536").End(3).Row + 1
    
        
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
        
        Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
            
        For Y = 1 To Cells(65536, 1).End(3).Row
            
            Data = Split(Cells(Y, 1), ";")
            
            Sütun = 1
            
            For Z = 0 To UBound(Data())
                If Sütun = 14 Then
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, Sütun) = CDate(Data(Z))
                Else
                Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, Sütun) = Data(Z)
                End If
                Sütun = Sütun + 1
            Next
            
            Satır = Satır + 1
        
        Next
        
        Kaynak_Dosya.Close True
    
    Next
    
    End If
    
    Next
    
    End If
    
    Son_Süre = Time
    
    Toplam_Süre = Format(Son_Süre - İlk_Süre, "hh:mm:ss")
    
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & "İşlem süresi ; " & Toplam_Süre, vbInformation
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst