Klasör ve alt klasörlerden isme bağlı olarak aynı hücredeki veriye çekmek listelemek

[nongeyikm]

klasör ve alt klasörlerden dosya isimlerine bağlı olarak belirli hücrelerdeki veriye çekmek bir bir sayfada özet şeklinde listelemek istiyorum. Her kişiye ait bir dosya var ve tüm kişilere ait dosyaların hücre ve tablo yapıları aynı.

Asıl istediğim şey ise, hangi hücreleri seçeceğimi listelenecek sayfada hücre adı ile benim belirlemiş olmam. Bu belirlenecek hücreler tüm çalışma sayfaları için geçerli.

örneğin :
tüm dosyalardan;
A2
B5
C8
T13
T17
VS.... tercih edeceğim hücreleri dosya ismini de a4 hücresine yazarak sağa doğru verileri çekmeli. Veri çekeceğim dosya sayısı yaklaşık 200 adet ve her dosyadan çekeceğim hücre verisi 50 civarında.

Saygılar,

 

[nongeyikm]

örnek veri sayfaları ektedir.

 

[Korhan Ayhan]

Dosyalarınızın hepsi aynı klasörde olsun.

Sonra kodu çalıştırın.

Option Explicit

Sub ADO_Verileri_Aktar()
    Dim Yol As String, Dosya As Variant, Zaman As Double
    Dim Baglanti As Object, S1 As Worksheet, Sorgu As String
    Dim Kayit_Seti As Object, Sayfa As String
    Dim Hucre_Adresi As Variant, Adres As Variant
    Dim Satir As Long, Sutun As Byte
      
    Zaman = Timer
  
    Application.ScreenUpdating = False
  
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Sayfa1")
      
    S1.Range("A4:L" & S1.Rows.Count).Clear
    Satir = 4
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    
    Dosya = Dir(Yol & "*.xls*")
    
    Hucre_Adresi = Array("G3:O3", "G4:O4", "G5:O5", "G6:O6", "G7:O7", "G8:O8", "G9:O9", "G10:O10", "G11:O11", "M30:P30", "M31:P31", "M32:P32")
    
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Yol & Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
        
            Sayfa = Replace(CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya), "Personel Tanıtım Formu_", "")
        
            For Each Adres In Hucre_Adresi
                Sorgu = "Select * From [" & Sayfa & "$" & Adres & "]"
                Kayit_Seti.Open Sorgu, Baglanti, 1, 1
                Sutun = Sutun + 1
                S1.Cells(Satir, Sutun).CopyFromRecordset Kayit_Seti
                If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            Next
            
            Satir = Satir + 1
            Sutun = 0
        End If
        If Baglanti.State <> 0 Then Baglanti.Close
        Dosya = Dir
    Wend
    
    S1.Range("H4:I" & Satir - 1).NumberFormat = "dd.mm.yyyy"
    S1.Range("J4:L" & Satir - 1).NumberFormat = "#,##0.00"
    S1.Columns.AutoFit
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
          
    Application.ScreenUpdating = True
          
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[nongeyikm]

Korhan Bey çok teşekkür ederim.

 

[tukayf]

Korhan Bey çok teşekkürler. Aynı mantık bana da lazım ancak veri çekilecek dosya isimleri standart değil bu kısmını revize edebilir miyiz. Hücre adreslerini yazdığınız kısımda birleştirilmiş hücre yerine tek bir hücre varsa sadece hücre ismini yazmamız yeterli mi acaba. Ayrıca bende bu şekilde bir hata veriyor sebebini anlayamadım.

 

[nongeyikm]

Korhan Bey,

M hücrelerindeki değerler (sayı) tarih formatında geliyor. hücre biçimini sayı yapmama rağmen tekrar veri çekince yine tarih formatına dönüyor. Bakabilirmisiniz?

 

[nongeyikm]

dosya isimleri ile dosyada yer alan isimleri kontrol ediniz. sicillere de bakınız.

 

[Korhan Ayhan]

@tukayf,

Kodun sağlıklı çalışması için dosya isimi ile içindeki sayfa adının aynı olması gerekiyor.

Personel Tanıtım Formu_AHMET MERT.xlsx

Tek hücre için adres bölümünü G3:G3 olarak yazabilirsiniz.

 

[tukayf]

dosya isimleri ile dosyada yer alan isimleri kontrol ediniz. sicillere de bakınız.

sicil ve isimleri değiştirdiğimde ise ilk resimdeki hata geliyor.

 

[tukayf]

@tukayf,

Kodun sağlıklı çalışması için dosya isimi ile içindeki sayfa adının aynı olması gerekiyor.

Personel Tanıtım Formu_AHMET MERT.xlsx

Tek hücre için adres bölümünü G3:G3 olarak yazabilirsiniz.

Sn. Hocam peki bendeki sayfa adlarının hemen hemen hepsi Sayfa1 şeklinde bu şekilde dönüştürebilir miyiz acaba.

 

[Korhan Ayhan]

Sorgu satırını aşağıdaki gibi düzenleyip kullanabilirsiniz.

Sorgu = "Select * From [Sayfa1" & "$" & Adres & "]"

 

[tukayf]

Sayfa = Replace(CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya), "Personel Tanıtım Formu_", "")

Hocam burda nasıl bir değişiklik yapmalıyım dosya adalarının bir standardı yok.

 

[Korhan Ayhan]

O satırı silebilirsiniz. Bu satırla sayfa adını alıyorduk. Sizdeki sayfa isimleri Sayfa1 olduğu için bu satıra gerek kalmamış oldu.

 

[tukayf]

Hocam çok teşekkürler. Zihninize sağlık.

 

[nongeyikm]

Korhan Bey,

M hücrelerindeki değerler (sayı) tarih formatında geliyor. hücre biçimini sayı yapmama rağmen tekrar veri çekince yine tarih formatına dönüyor. Bakabilirmisiniz?

 

[Korhan Ayhan]

Sayı biçimini makro kaydet ile elde ettikten sonra oluşan kodu benim verdiğim koda entegre edip kullanabilirsiniz. Hem bu şekilde makrolara adım atmış olursunuz.

Uyarlama yapamam derseniz belirtin destek olalım.

 

[nongeyikm]

Teşekkür ederim. beyninize sağlık

 

[Korhan Ayhan]

Kendinizin çözmesine sevindim.

Ben de #3 nolu mesajımda ki koda hücreleri biçimlendiren kod satırlarını ekledim.

 

[tukayf]

Sorgu satırını aşağıdaki gibi düzenleyip kullanabilirsiniz.

Sorgu = "Select * From [Sayfa1" & "$" & Adres & "]"

Sayfa adının önemi olmadan verileri nasıl çekebiliriz hocam. Activesheet denedim yapamadım. Ordaki kodu nasıl değiştirmeliyim.

 

[Korhan Ayhan]

Bunun için önce kapalı dosyadaki sayfa adını öğrenmek gerekiyor. Eğer kapalı dosyada birden fazla sayfa varsa hangisinden veri alınacağını bilmeniz gerekiyor.

Aşağıdaki linkteki mesajda buna ilişkin kodlama var. Kendinize uyarlayabilirsiniz. (Anahtar kelime; Catalog)

Kapalı Dosyadan Veri Çekme

Deneyin bakalım olmuş mu? Yapı itibari ile olmuş elinize sağlık. Tek kusuru Aylık ebat dönüşü sheetinde bakiye tonaj sütununa boyları toplayıp getiriyor. Bakiye tonajı toplayıp getirmesi için küçük bir dokunuşunuza ihtiyaç var sanırım. :)

www.excel.web.tr