• DİKKAT

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

Ado ile kapalı dosyadan veri alma

D

dsaffethoscan

Katılım
6 Ocak 2012
Mesajlar
56
Excel Vers. ve Dili
2007
Merhaba,
1000 üzerindeki kapalı dosyadan ado ile verileri almam gerekiyor.
Verilerin toplanacağı dosya DenemeAdo.xls dosyasıdır. Aynı klasör içinde 1000 civarı dosya vardır. Ve hegün 20-50 arası dosya eklenmektedir. Verilerin alınacağı dosyaların adlarını manuel olarak DenemeAdo dosyasının A sütununa giriş yapacağım. B-C-D sütununa kapalı haldeki dosyalardan verileri alacaktır. Örnekler ektedir. Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.
 

Ekli dosyalar

Merhaba dosyaların olduğu klasörü belirterek ekteki kodları denermisiniz.

DeneneAdo dosyası farklı klasörde olması gerekir. ben ekteki kodlarda "C:\Stok\Dosyalar\" şeklinde tanımladım siz o alanı kendi klasörünüzün yolu ile değiştirin.


Bu arada hangi kağıt firmasındasınız?

Kod: 
Sub DenemeAdo()
    Dim Yol As String, Dosya As String
    Dim K2 As Workbook
    On Error Resume Next
    Dim dizi1(1 To 500000, 1 To 3)

  [B]  Yol = "C:\Stok\Dosyalar\" [/B]

    Dosya = Dir(Yol & "*.xls")
    Do While Len(Dosya) > 0
    Set K2 = Workbooks.Open(Yol & Dosya, False, False)
    Windows(Dosya).Activate
    Sheets("Sayfa1").Select
    For x1 = 2 To Cells(Rows.Count, 1).End(3).Row
    Sat = Sat + 1
    dizi1(Sat, 1) = Cells(x2, 1)
    dizi1(Sat, 2) = Cells(x2, 2)
    dizi1(Sat, 3) = Cells(x2, 3)
    Next x1
    K2.Close True
    Dosya = Dir()
    Loop
    Windows("DenemeAdo").Activate
    Range("B2:D" & Sat).Value = dizi1()

End Sub
 
İlginiz için teşekkürler. Kağıtcı değil matbaacıyım. Denedim ama beceremedim. Bizim her iş için açtığımız üretim formlarımız var. Bu formların son sheet'inde ozet diye bir sayfa var. Ayrıca üretim formlarının toplandığı bir liste var. Bu da iş takip listesi. Daha önce bir arkadaşın yardımı ile Ozet sheet'indeki bilgileri makro ile aldırtıyordum. Ama dosya büyüyünce makro1 (Güncelle) makrosu hata vermeye başladı. Yani 1 aydır makroyu çalıştıramadım. Ben de üretim form nolarını elle gireyim dedim. Böylece sorunu çözerim diye düşündüm. Bu sebepten böyle bir konu açtım. Ozet sheet'inde ekte göreceğiniz gibi 15 satır var. 2 formu ve İş Takip Listesini yolluyorum. İyi Çalışmalar.
 

Ekli dosyalar

Ekteki kodları denermisiniz. Üretim numarası olanları tekrar aktarmayacaktır.

Kod: 
Sub DenemeAdo()
    Dim Yol As String, Dosya As String
    Dim K2 As Workbook
    On Error Resume Next
    Dim dizi1(1 To 500000, 1 To 15)

    Yol = "\\Server\KURUMSAL\PAZARLAMA\Is_Takip_Listesi_01-11-2012\"
   
    Dosya = Dir(Yol & "*.xls")
    Do While Len(Dosya) > 0
    Set K2 = Workbooks.Open(Yol & Dosya, False, False)
    Windows(Dosya).Activate
    Sheets("Ozet").Select
    For x1 = 2 To Cells(Rows.Count, 2).End(3).Row
    Sat = Sat + 1
    dizi1(Sat, 1) = Cells(x1, 1)
    dizi1(Sat, 2) = Cells(x1, 2)
    dizi1(Sat, 3) = Cells(x1, 3)
    dizi1(Sat, 4) = Cells(x1, 4)
    dizi1(Sat, 5) = Cells(x1, 5)
    dizi1(Sat, 6) = Cells(x1, 6)
    dizi1(Sat, 7) = Cells(x1, 7)
    dizi1(Sat, 8) = Cells(x1, 8)
    dizi1(Sat, 9) = Cells(x1, 9)
    dizi1(Sat, 10) = Cells(x1, 10)
    dizi1(Sat, 11) = Cells(x1, 11)
    dizi1(Sat, 12) = Cells(x1, 12)
    dizi1(Sat, 13) = Cells(x1, 13)
    dizi1(Sat, 14) = Cells(x1, 14)
    dizi1(Sat, 15) = Cells(x1, 15)
    Next x1
    K2.Close False
    Dosya = Dir()
    Loop
    Windows("Is_Takip_Listesi").Activate
    
    For x2 = 1 To Sat
    adet = WorksheetFunction.CountIf(Range("A45:A" & Cells(Rows.Count, 2).End(3).Row), dizi1(x2, 1))
    If adet = 0 Then
    Satr = Cells(Rows.Count, 2).End(3).Row + 1
    Cells(Satr, 2) = dizi1(x2, 1)
    Cells(Satr, 3) = dizi1(x2, 2)
    Cells(Satr, 4) = dizi1(x2, 3)
    Cells(Satr, 5) = dizi1(x2, 4)
    Cells(Satr, 6) = dizi1(x2, 5)
    Cells(Satr, 7) = dizi1(x2, 6)
    Cells(Satr, 8) = dizi1(x2, 7)
    Cells(Satr, 9) = dizi1(x2, 8)
    Cells(Satr, 10) = dizi1(x2, 9)
    Cells(Satr, 11) = dizi1(x2, 10)
    Cells(Satr, 12) = dizi1(x2, 11)
    Cells(Satr, 13) = dizi1(x2, 12)
    Cells(Satr, 14) = dizi1(x2, 13)
    Cells(Satr, 15) = dizi1(x2, 14)
    Cells(Satr, 16) = dizi1(x2, 15)
    End If
    Next x2
End Sub
 
Son düzenleme:
Yeni bir modül ekledim. Yukarıdaki kodları bu modüle kopyaladım. Yeni fişleri ekle butonuna bağladım. Çalıştırdığımda düzgün çalışmadı. Sorunlar şunlar:
1- Listede zaten var olan 10-15 kadar dosyayı (7045'den itibaren) açtı sonra İş_Takip_Listesi zaten açık tekrar açayımmı dedi. Evet dediğimde yeniden açıp excell kilitlendi.
2- ikinci denemede açma dedim. 10-15 kadar dosyadan sonra 7200'e kadar dosyaları açarken ben esc ile durdurdum.

Anladığım kadar B sütunundaki yazılan eski formları açmaması gerekiyor. Bunu engellememiz gerek. Ve ya B'ye elle yazılanları açıp verileri alması gerekiyor.
Yani
Dosya = Dir(Yol & "*.xls")
Satırını
Dosya = Dir(Yol & "Range ("B,Satır").xls")
gibi olması gerekiyor.

Ayrıca İş_Takip_Listesi'ni ve listede olmayan tek bir dosyayı benim bilgisayardaki başka bir klasöre aldım. Bakalım o zaman çalışacak mı diye. Tabi yolu da değiştirdim. Hiçbir işlem yapmadı. Yani tek formun ozet sheet'inden bilgileri almadı.
 
Kodlarda bir kaç değişiklik daha yaptım inceler misiniz.

Kod: 
Sub DenemeAdo()
    Dim Yol As String, Dosya As String
    Dim K2 As Workbook
    On Error Resume Next
    Dim dizi1(1 To 500000, 1 To 15)
    Set ds = CreateObject(Scripting.FileSystemObject)
    
    Yol = "\\Server\KURUMSAL\PAZARLAMA\Is_Takip_Listesi_01-11-2012\"
    
    Dosya = Dir(Yol & "*.xls")
    Do While Len(Dosya) > 0
    f = Mid(Dosya, 1, (Len(Dosya) - 4)) * 1
    adet2 = WorksheetFunction.CountIf(Workbooks("Is_Takip_Listesi.xls").Sheets("Is_Takip Listesi").Range("B45:B" & Cells(Rows.Count, 2).End(3).Row), f)
    If adet2 = 0 And f <> "Is_Takip Listesi" Then
    Set K2 = Workbooks.Open(Yol & Dosya, False, False)
    Windows(Dosya).Activate
    Sheets("Ozet").Select
    For x1 = 2 To Cells(Rows.Count, 2).End(3).Row
    Sat = Sat + 1
    dizi1(Sat, 1) = Cells(x1, 1)
    dizi1(Sat, 2) = Cells(x1, 2)
    dizi1(Sat, 3) = Cells(x1, 3)
    dizi1(Sat, 4) = Cells(x1, 4)
    dizi1(Sat, 5) = Cells(x1, 5)
    dizi1(Sat, 6) = Cells(x1, 6)
    dizi1(Sat, 7) = Cells(x1, 7)
    dizi1(Sat, 8) = Cells(x1, 8)
    dizi1(Sat, 9) = Cells(x1, 9)
    dizi1(Sat, 10) = Cells(x1, 10)
    dizi1(Sat, 11) = Cells(x1, 11)
    dizi1(Sat, 12) = Cells(x1, 12)
    dizi1(Sat, 13) = Cells(x1, 13)
    dizi1(Sat, 14) = Cells(x1, 14)
    dizi1(Sat, 15) = Cells(x1, 15)
    Next x1
    K2.Close False
    End If
    Dosya = Dir()
    Loop
    Windows("Is_Takip_Listesi").Activate
    
    For x2 = 1 To Sat
    adet = WorksheetFunction.CountIf(Range("B45:B" & Cells(Rows.Count, 2).End(3).Row), dizi1(x2, 1))
    If adet = 0 Then
    Satr = Cells(Rows.Count, 2).End(3).Row + 1
    Cells(Satr, 2) = dizi1(x2, 1)
    Cells(Satr, 3) = dizi1(x2, 2)
    Cells(Satr, 4) = dizi1(x2, 3)
    Cells(Satr, 5) = dizi1(x2, 4)
    Cells(Satr, 6) = dizi1(x2, 5)
    Cells(Satr, 7) = dizi1(x2, 6)
    Cells(Satr, 8) = dizi1(x2, 7)
    Cells(Satr, 9) = dizi1(x2, 8)
    Cells(Satr, 10) = dizi1(x2, 9)
    Cells(Satr, 11) = dizi1(x2, 10)
    Cells(Satr, 12) = dizi1(x2, 11)
    Cells(Satr, 13) = dizi1(x2, 12)
    Cells(Satr, 14) = dizi1(x2, 13)
    Cells(Satr, 15) = dizi1(x2, 14)
    Cells(Satr, 16) = dizi1(x2, 15)
    End If
    Next x2
End Sub
 
Merhaba Hüseyin Bey,
Oldu.:) Çok teşekkürler.
Konuyla ilgili birşeyler sormak istiyorum.
1- Daha önceki hali ado ileydi. Şimdi böyle yapmak daha mı mantıklı? Bu şekilde yapılan makroda yeni yaratılan dosyaları açıp listeye alıyor.
2- Makro kaydet dediğimde makroyu kaydederken dosya adını makroda "Is_Takip Listesi" şeklinde kaydediyor. Halbuki dosya adı "Is_Takip_Listesi". İkinci alt tireyi kaydetmiyor. Bu nedendir?
 
Hangisinin daha hızlı çalıştığı önemli gibi.

2 soruyu tam anlayamadım hangi kodlarda yapıyor ?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst