Kapalı dosyalardan veri aldırma

[dsaffethoscan]

Merhaba
Dosya adları 7045'den başlayıp 21400'e kadar 14355 adet dosyam var. Örnek olması açısından iki tanesini ekliyorum. 14355 dosyayı tek tek açmak yerine makro ile sırayla her dosyayı açtırıp her dosyanın "Uretim_Formu" sayfasının P42 hücresindeki değeri kopyalayıp boş bir exelde sol sütuna dosya adı sağ sütuna dosyanın P42'daki değeri makro ile yapıştırmak istiyorum.

Kendim yapmaya çalıştım ama bir türlü beceremedim. Yardımlarınızı rica ediyorum.

 

[Erdem Akdemir]

Merhaba,

Masaüstünde deneme adında bir klasöre dosyaları kopyalayınız.

Sub DENEME()

DoEvents
Cells.Clear

Set con = VBA.CreateObject("adodb.Connection")

Set fso = VBA.CreateObject("scripting.filesystemobject")
yol = "C:\Users\" & Environ("username") & "\Desktop\deneme\"
x = 1

For Each kls In fso.getfolder(yol).Files

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
kls.Path & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select * from[Uretim_Formu$P42:P42]"
Set rs = con.Execute(sorgu)

Range("A" & x) = kls.Path
Range("B" & x).CopyFromRecordset rs

con.Close
x = x + 1

Next kls

End Sub

 

[dsaffethoscan]

Çok teşekkür ederim hızla yapıyor. Sorunlu dosya olunca makro duruyor. Durduğu sorunlu dosyaları manuel yaparak ilerliyorum. Ama çok işimi gördü teşekkürler.

 

[hakankilic]

Run-time error '429':
ActiveX component can't create object

Hatası aldım. Ne yapmalıyım?

Reference - VBAProject de bir seçim mi yapmalıyım.?

 

[Korhan Ayhan]

Alternatif olarak aşağıdaki kod kullanılabilir.

Hız olarak daha iyi sonuç veriyor.

Sub Dosyalardan_Veri_Al()
    Dim Zaman As Double, Dosya_Sistemi As Object, Dosya As Object, Yol As String, Satir As Long
        
    Zaman = Timer
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set Dosya_Sistemi = CreateObject("Scripting.Filesystemobject")
    Yol = "C:\Users\" & Environ("username") & "\Desktop\deneme\"
        
    Range("A:B").ClearContents
    Satir = 1
        
    For Each Dosya In Dosya_Sistemi.GetFolder(Yol).Files
        Cells(Satir, 1) = Dosya
        Cells(Satir, 2).Formula = "=INDEX('" & Yol & "[" & Dosya.Name & "]Uretim_Formu'!P42,1)"
        Cells(Satir, 2).Value = Cells(Satir, 2).Value
        Satir = Satir + 1
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Veri aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub