• DİKKAT

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

KAPALI Excel Dosyalarından VERİ Çekmek

ERMAN SAYINALP

ERMAN SAYINALP

Altın Üye
Katılım
11 Eylül 2008
Mesajlar
173
Excel Vers. ve Dili
Excel 2016 Türkçe
Merhabalar,

Aynı DİZİN altında oluşturulmuş, ancak KAPALI (Pasif) olan 1000 tane Dosyanın A1 Hücresinden, aynı DİZİN altındaki İCMAL Dosyasının A1 Hücresine VERİ Çekmek istiyorum.
Bu ihtiyaca cevap verecek bir FONKSİYON'a ihtiyacım var.

Değerli yardımlarınız lütfen.
 
Bu şekilde dener misiniz ?
Kod: 
Sub KapaliDosyadanVeriAl()
    Yol = ActiveWorkbook.Path & "\"
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(Yol)
    Set dc = f.Files
    i = 1
    Columns(1).Clear
    For Each dosya In dc
        i = i + 1
        If dosya.Name = "Icmal.xlsm" Then GoTo 10
        If dosya.Name = "~$Icmal.xlsm" Then GoTo 10
        KapaliDosya = dosya.Name
        Adres = "'" & Yol & "[" & KapaliDosya & "]Sayfa1'!R1C1"
        Cells(i, 1) = ExecuteExcel4Macro(Adres)
10
    Next
    MsgBox "İşlem Tamamlandı"
End Sub
 
hamitcan' Alıntı:
Bu şekilde dener misiniz ?
Kod: 
Sub KapaliDosyadanVeriAl()
    Yol = ActiveWorkbook.Path & "\"
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(Yol)
    Set dc = f.Files
    i = 1
    Columns(1).Clear
    For Each dosya In dc
        i = i + 1
        If dosya.Name = "Icmal.xlsm" Then GoTo 10
        If dosya.Name = "~$Icmal.xlsm" Then GoTo 10
        KapaliDosya = dosya.Name
        Adres = "'" & Yol & "[" & KapaliDosya & "]Sayfa1'!R1C1"
        Cells(i, 1) = ExecuteExcel4Macro(Adres)
10
    Next
    MsgBox "İşlem Tamamlandı"
End Sub
Genişletmek için tıkla ...


Değerli Hamitcan,

Ellerinize sağlık, çok teşekkür ederim. Yukarıdaki FONKSİYON işin mantığının tam karşılığı olmuş, sorunsuz olarak da çalışmakta ancak, biraz daha geliştirmeme yardımcı olmanızı istirham ediyorum. Şöyle ki;

1- KAYNAK Dosyaların A1'lerinden, HEDEF Dosyanın A1'ine VERİ Akışını,

KAYNAK Dosyaların A1, A2, A3 vs den, HEDEF Dosyanın A1, A2, A3'lerine yada
KAYNAK Dosyaların A1, B1, C1 vs den, HEDEF Dosyanın A1, B1, C1'lerine taşımak,

2- KAYNAK Dosyaların "Dosya Adları" nı, HEDEF Dosyadaki taşınan VERİ'lerin önündeki yada sonundaki Hücreye Otomatik yazdırmak,

3-Verdiğiniz Çözüm Fonksiyonunda, Makro çalıştırıldığında HEDEF Dosyanın gösterilmesini istemektedir. Bunu Otomatik göstermek,

4-Verdiğiniz Çözüm Fonksiyonunda, A1 Hücresini boş geçmekte, A2 Hücresine #BAŞV yazmakta, VERİ'ler A3 ve sonrasına akmaya başlamaktadır. A1'den itibaren VERİ Akışını sağlamak,

Konularında da değerli yardımlarınızı istirham ederim.
 
Erman bey altın üyesiniz.
Örnek dosya paylaşırsanız daha hızlı ve doğru yanıt alırsınız.
 
Son düzenleme:
4.sorunuzu anlamadım. Ayrıca hata aldığınız dosyada veri olmayabilir mi ?
Kod: 
Sub KapaliDosyadanVeriAl()
    Yol = ActiveWorkbook.Path & "\"
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(Yol)
    Set dc = f.Files
'    i = 1
    Columns("a:d").Clear
    For Each dosya In dc
        i = i + 1
        If dosya.Name = "Icmal.xlsm" Then GoTo 10
        If dosya.Name = "~$Icmal.xlsm" Then GoTo 10
        KapaliDosya = dosya.Name
        Adres = "'" & Yol & "[" & KapaliDosya & "]Sayfa1'!R1C1:R1C3"
        Range("A" & i & ":c" & i) = ExecuteExcel4Macro(Adres)
        Range("d" & i) = dosya.Name
10
    Next
    MsgBox "İşlem Tamamlandı"
End Sub
 
hamitcan' Alıntı:
4.sorunuzu anlamadım. Ayrıca hata aldığınız dosyada veri olmayabilir mi ?
Kod: 
Sub KapaliDosyadanVeriAl()
    Yol = ActiveWorkbook.Path & "\"
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(Yol)
    Set dc = f.Files
'    i = 1
    Columns("a:d").Clear
    For Each dosya In dc
        i = i + 1
        If dosya.Name = "Icmal.xlsm" Then GoTo 10
        If dosya.Name = "~$Icmal.xlsm" Then GoTo 10
        KapaliDosya = dosya.Name
        Adres = "'" & Yol & "[" & KapaliDosya & "]Sayfa1'!R1C1:R1C3"
        Range("A" & i & ":c" & i) = ExecuteExcel4Macro(Adres)
        Range("d" & i) = dosya.Name
10
    Next
    MsgBox "İşlem Tamamlandı"
End Sub
Genişletmek için tıkla ...

4. Sorumdaki A2 Hücresine #BAŞV yazmakta cümlesini iptal ettim, sanırım hata bende oldu, ancak diğerleri geçerli,

İsterseniz bir kez de siz kontrol edin. Örnek DOSYALAR'ın olduğu KLASÖR'ü ekte gönderiyorum.

Teşekkür ederim.
 

Ekli dosyalar

İsterseniz, yukarıda olan biteni boşverin. Ekte gönderdiğim, KLASÖR ve içeriği DOSYALARI değerlendirin.

Teşekkür ederim.
 

Ekli dosyalar

Merhaba.

Sayın @hamitcan 'ın verdiği kod'dan hareketle aşağıdaki gibi olabilir.
Veri alıncak sütunları kırmızı renklendirdğim 1 To 5 (A'den E'ye) kısmını değiştirerek kullanabilirsiniz.
Mavi renklendirdğim 1 sayısı ise veri alınacak satır numarasıdır.
İlgili kod satırındaki Sayfa1'!R1C" & sut) kısmını Sayfa1'!R10C" & sut) olarak değiştirirseniz 10'uncu satırlardaki verileri çağırmış olursunuz.
Rich (BB code): 
Sub KapaliDosyadanVeriAl()
    Yol = ActiveWorkbook.Path & "\"
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(Yol)
    Set dc = f.Files
    Cells.Clear
    For Each dosya In dc
        i = i + 1
        If dosya.Name = "ICMAL.xlsm" Or dosya.Name = "~$ICMAL.xlsm" Then GoTo 10
        KapaliDosya = dosya.Name
        For sut = 1 To 5
            Cells(i, sut) = ExecuteExcel4Macro("'" & Yol & "[" & KapaliDosya & "]Sayfa1'!R1C" & sut)
        Next
        Cells(i, sut) = dosya.Name
10: Next
    MsgBox "İşlem Tamamlandı"
End Sub
 
Son düzenleme:
Alternatif,

Kod: 
Sub derd()

Cells.Clear
dosya = ThisWorkbook.FullName
Set fso = VBA.CreateObject("scripting.filesystemobject")
Set con = VBA.CreateObject("adodb.Connection")

yol = "C:\Users\" & Environ("UserName") & "\Desktop\Örnek Klasör\"
x = 1
For Each kls In fso.getfolder(yol).Files

If kls.Path <> dosya And kls.Attributes = 32 Then
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
kls.Path & ";extended properties=""Excel 12.0;hdr=no"""

Set rs = con.Execute("select * from[sayfa1$A1:E1]")

Cells(x, "a").CopyFromRecordset rs
Cells(x, "f") = kls.Name
x = x + 1
con.Close

End If
Next

End Sub
 
Ömer BARAN' Alıntı:
Merhaba.

Sayın @hamitcan 'ın verdiği kod'dan hareketle aşağıdaki gibi olabilir.
Veri alıncak sütunları kırmızı renklendirdğim 1 To 5 (A'den E'ye) kısmını değiştirerek kullanabilirsiniz.
Mavi renklendirdğim 1 sayısı ise veri alınacak satır numarasıdır.
İlgili kod satırındaki Sayfa1'!R1C" & sut) kısmını Sayfa1'!R10C" & sut) olarak değiştirirseniz 10'uncu satırlardaki verileri çağırmış olursunuz.
Rich (BB code): 
Sub KapaliDosyadanVeriAl()
    Yol = ActiveWorkbook.Path & "\"
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(Yol)
    Set dc = f.Files
    Cells.Clear
    For Each dosya In dc
        i = i + 1
        If dosya.Name = "ICMAL.xlsm" Or dosya.Name = "~$ICMAL.xlsm" Then GoTo 10
        KapaliDosya = dosya.Name
        For sut = 1 To 5
            Cells(i, sut) = ExecuteExcel4Macro("'" & Yol & "[" & KapaliDosya & "]Sayfa1'!R1C" & sut)
        Next
        Cells(i, sut) = dosya.Name
10: Next
    MsgBox "İşlem Tamamlandı"
End Sub
Genişletmek için tıkla ...


Sevgili Üstadım,

Harikasınız, size ve nezdinizde hamitcan ve Erdem_34 'e emeklerinizden dolayı çok teşekkür ederim.

Varolunuz.
 
Erdem_34' Alıntı:
Alternatif,

Kod: 
Sub derd()

Cells.Clear
dosya = ThisWorkbook.FullName
Set fso = VBA.CreateObject("scripting.filesystemobject")
Set con = VBA.CreateObject("adodb.Connection")

yol = "C:\Users\" & Environ("UserName") & "\Desktop\Örnek Klasör\"
x = 1
For Each kls In fso.getfolder(yol).Files

If kls.Path <> dosya And kls.Attributes = 32 Then
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
kls.Path & ";extended properties=""Excel 12.0;hdr=no"""

Set rs = con.Execute("select * from[sayfa1$A1:E1]")

Cells(x, "a").CopyFromRecordset rs
Cells(x, "f") = kls.Name
x = x + 1
con.Close

End If
Next

End Sub
Genişletmek için tıkla ...

Emeklerinizden dolayı çok teşekkür ederim.
 
hamitcan' Alıntı:
4.sorunuzu anlamadım. Ayrıca hata aldığınız dosyada veri olmayabilir mi ?
Kod: 
Sub KapaliDosyadanVeriAl()
    Yol = ActiveWorkbook.Path & "\"
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(Yol)
    Set dc = f.Files
'    i = 1
    Columns("a:d").Clear
    For Each dosya In dc
        i = i + 1
        If dosya.Name = "Icmal.xlsm" Then GoTo 10
        If dosya.Name = "~$Icmal.xlsm" Then GoTo 10
        KapaliDosya = dosya.Name
        Adres = "'" & Yol & "[" & KapaliDosya & "]Sayfa1'!R1C1:R1C3"
        Range("A" & i & ":c" & i) = ExecuteExcel4Macro(Adres)
        Range("d" & i) = dosya.Name
10
    Next
    MsgBox "İşlem Tamamlandı"
End Sub
Genişletmek için tıkla ...


Emeklerinizden dolayı çok teşekkür ederim.
 
hamitcan' Alıntı:
Bu şekilde dener misiniz ?
Kod: 
Sub KapaliDosyadanVeriAl()
    Yol = ActiveWorkbook.Path & "\"
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(Yol)
    Set dc = f.Files
    i = 1
    Columns(1).Clear
    For Each dosya In dc
        i = i + 1
        If dosya.Name = "Icmal.xlsm" Then GoTo 10
        If dosya.Name = "~$Icmal.xlsm" Then GoTo 10
        KapaliDosya = dosya.Name
        Adres = "'" & Yol & "[" & KapaliDosya & "]Sayfa1'!R1C1"
        Cells(i, 1) = ExecuteExcel4Macro(Adres)
10
    Next
    MsgBox "İşlem Tamamlandı"
End Sub
Genişletmek için tıkla ...

Merhabalar, kod çok sade olmuş, benim de bir şekilde işime yaradı. Burada bir ayrıntı öğrenmek istiyorum;

Mevcut kod ile verilen folder içerisindeki Excel dosyalar taranıyor, bu kodu verilen klasörün alt klasörleri de içine alacak şekilde nasıl değiştirebiliriz ?
 
ongbey' Alıntı:
Merhabalar, kod çok sade olmuş, benim de bir şekilde işime yaradı. Burada bir ayrıntı öğrenmek istiyorum;

Mevcut kod ile verilen folder içerisindeki Excel dosyalar taranıyor, bu kodu verilen klasörün alt klasörleri de içine alacak şekilde nasıl değiştirebiliriz ?
Genişletmek için tıkla ...
Alt klasörler için ayrı bir kod yapısı mevcut. Aslında 2007 öncesi versiyonlarda Application.FileSearch fonksiyonu vardı. Sonradan güvenlik sebebiyle kaldırıldı zannedersem. Size tavsiyem Halit Bey'in örneklerine bakmanız. Konu ile ilgili paylaşımları mevcut.
 
hamitcan' Alıntı:
Alt klasörler için ayrı bir kod yapısı mevcut. Aslında 2007 öncesi versiyonlarda Application.FileSearch fonksiyonu vardı. Sonradan güvenlik sebebiyle kaldırıldı zannedersem. Size tavsiyem Halit Bey'in örneklerine bakmanız. Konu ile ilgili paylaşımları mevcut.
Genişletmek için tıkla ...

Bu haber iyi olmadı ama onu bir şekilde çözebilirim sanıyorum.

Bir de file tipi konusunu açıklayabilir misiniz? Bu kod klasördeki tüm dosyaları tarıyor, sadece Excel dosyalarını taraması için için nasıl bir değişiklik yapılabilir?
 
Herkese merhaba, aşağıdaki kodu, folder içindeki sadece Excel dosyalarını filtrelemek için nasıl değiştirebilirim, yardımcı olur musunuz?

Yol = ActiveWorkbook.Path & "\"
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(Yol)
Set dc = f.Files
 
Kod: 
If ds.GetExtensionName(dosya.Name) = "xlsx" Or ds.GetExtensionName(dosya.Name) = "xls" Then
şeklinde dener misiniz ?
 
hamitcan' Alıntı:
Kod: 
If ds.GetExtensionName(dosya.Name) = "xlsx" Or ds.GetExtensionName(dosya.Name) = "xls" Then
şeklinde dener misiniz ?
Genişletmek için tıkla ...

Evet bu şekilde çalışıyor ama filtre şeklinde bir imkan olsa idi daha hızlı çalışırdı, yüzlerce dosya ve server' dan çalışıldığında IF' ler yavaşlık yaratıyor. Sizin bu metotla Excel dosyalarını hedeflemeyi başardım. Bir ben ayrıca her açtığım dosyada bir hücreyi kontrol edip sonuç olumlu ise veri almak istiyordum. Bu durumda sizin kodunuzdan yararlanarak aşağıdaki formatta bir kaç satır ekledim. Fakat kontrol edilen hücre koşula uygun değilse makro kilitleniyor. Bunun için farklı bir çözü var mı acaba ? (On error resume next yaptım yine kilitlendi.)

adres = "'" & yol & "[" & KapaliDosya & "]Sayfa1'!R" & 9 & "C1"
kontrol = ExecuteExcel4Macro(adres)
If kontrol = "Current" Then
...........
..........
End if
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst