Kapalı dosyalardan koşullu veri almak

[talebeyim]

Private Sub CommandButton1_Click()
    Dim Con As Object, Rs As Object, Fso As Object, Klasor As Object, Dosyalar As Object
    Dim Sorgu As String, Yol As String, Dosya As String
    Dim Sutun As Byte
    Set Con = CreateObject("AdoDb.Connection")
    Set Rs = CreateObject("AdoDb.RecordSet")
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Yol = ThisWorkbook.Path
    Set Klasor = Fso.GetFolder(Yol)
    Range("B2:D5").ClearContents
    Sutun = 2
    For Each Dosyalar In Klasor.Files
    If Dosyalar.Name < "ana.xls" Then
    Dosya = Replace(Dosyalar.Name, ".xls", "")
    Con.Open "Provider=Microsoft.Jet.OleDb.4.0;Data Source=" & _
    ThisWorkbook.Path & "\" & Dosya & ".xls" & ";Extended Properties=""Excel 8.0;HDR=NO"""
    Sorgu = "Select F4 FROM [Sayfa1$A2:D5]"
    Rs.Open Sorgu, Con, 1, 3
    Cells(2, Sutun).CopyFromRecordset Rs
    Rs.Close
    Con.Close
    Sutun = Sutun + 1
    End If
    Next Dosyalar
    Set Con = Nothing
    Set Rs = Nothing
    Set Fso = Nothing
    Set Klasor = Nothing
    Set Dosyalar = Nothing
    Yol = vbNullString
    Dosya = vbNullString
End Sub

Bu mesajda görüldüğü 3 ayrı excel kitabında Sayfa 1deki D sütunlarından veri alıyor ve Ana isimle tabloda topluyor. Ben bu kodları düzenleyemediğim için destek istiyorum.

istediğim şudur.
Ana isimli dosyanın sütun 1.deki yazılana bakacak, tablo1de onu bulduğunda karşısındaki degeri ana tablosuna getirecek. ve bu işlemi Tablo1 ve Tablo2 dede yapacak. Ayrıca sadece ilk dört satırı değil tüm sutun icin bunu yapacak.
Teşekkür ederim.

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

Private Sub CommandButton1_Click()
Set Con = CreateObject("ADODB.Connection")
Set Fso = CreateObject("Scripting.FileSystemObject")
Yol = ThisWorkbook.Path
Set Klasor = Fso.GetFolder(Yol)
Range("B2:D5").ClearContents
Sutun = 2
For Each Dosyalar In Klasor.Files
If Dosyalar.Name < "ana.xls" Then
Dosya = Replace(Dosyalar.Name, ".xls", "")
Con.Open "Provider=Microsoft.Jet.OleDb.4.0;Data Source=" & _
ThisWorkbook.Path & "\" & Dosya & ".xls" & ";Extended Properties=""Excel 8.0;HDR=NO"""
For a = 2 To [a65536].End(3).Row
Sorgu = "Select F4 FROM [Sayfa1$A2:D5] where F1=" & Cells(a, "a")
Set Rs = Con.Execute(Sorgu)
If Rs.BOF = False Then
Cells(a, Sutun) = Rs.fields(0)
Else
Cells(a, Sutun) = ""
End If
Next
Con.Close
Sutun = Sutun + 1
End If
Next Dosyalar
Set Con = Nothing
Set Rs = Nothing
Set Fso = Nothing
End Sub

 

[talebeyim]

Levent bey teşekkür ederim, zaten önceki eklemiş olduğum tablo ile aynı işi yapıyor, ama benim istediğim bu değil, bu sütunda ne varsa tamamını ilgili sütuna getiriyor benim istediğim ise, Ana dosyasına bakacak Orada eğer "a" isimli bir karakter var ve bundan birkaç tane var ise a'ların toplamlarını Ana isimli excele getirecek...

daha anlaşılır olsun diye tekrar derledim, sizin kodlarınızı kullandım.

 

[talebeyim]

Yardım beklediğim konu halen günceldir.

 

[talebeyim]

Arkadaslar soru anlaşılmadıysa tekrar soruyum, Levent beyin gönderdiği kodlar, farklı kitaplardaki birinci sayfalardaki verileri aynen getiriyor. ben mkerrer satırların toplamını getirsin istiyorum lütfen bakabilirmisiniz ?

 

[Levent Menteşoğlu]

Eklediğiniz dosyalar yazdıklarınızı desteklemiyor. Dolayısıyla hiç bir şey anlaşılmıyor.

 

[talebeyim]

hakli olabilirsiniz. konuyu ben bildigim icin herkez konuya vakifmis gibi saniyorum. soyle anlatayim abi yapmak istedigim ozetle sudur. 3 excel kitabini b sutunlarini ana isimli excele getirmek. fakat kitaplar 1, 2, 3 diye geciyor bunun anlami. 1.kitabin b sutunu ana isimli dosyanin bsine, 2.kitabin b sutunu ana.nin csine, 3.kitabin bsi ana.nin dsine gelmesi gerekiyor. aslinda sizin yaptiginiz bu. iste ben bundan farkli olarak ana isimli kitabin a,sindaki degere gore etopla seklinde getirmesini istiyorum. yani eger 1. kitapta a sutununda elma isimli deger 4tane ise ana isimli kitabta bulunan elma ya toplayarak getirmesini istiyorum. kisaca sunu dusunun lutfen bir sayfada elma var diger sayfadaki elma toplamini getirmek. tek amacim budur. Anlayisiniz ve sabirla bana yardimci olmaya calistiginiz icin ayrica tesekkur ederim.

 

[halit3]

hakli olabilirsiniz. konuyu ben bildigim icin herkez konuya vakifmis gibi saniyorum. soyle anlatayim abi yapmak istedigim ozetle sudur. 3 excel kitabini b sutunlarini ana isimli excele getirmek. fakat kitaplar 1, 2, 3 diye geciyor bunun anlami. 1.kitabin b sutunu ana isimli dosyanin bsine, 2.kitabin b sutunu ana.nin csine, 3.kitabin bsi ana.nin dsine gelmesi gerekiyor. aslinda sizin yaptiginiz bu. iste ben bundan farkli olarak ana isimli kitabin a,sindaki degere gore etopla seklinde getirmesini istiyorum. yani eger 1. kitapta a sutununda elma isimli deger 4tane ise ana isimli kitabta bulunan elma ya toplayarak getirmesini istiyorum. kisaca sunu dusunun lutfen bir sayfada elma var diger sayfadaki elma toplamini getirmek. tek amacim budur. Anlayisiniz ve sabirla bana yardimci olmaya calistiginiz icin ayrica tesekkur ederim.

Dosyayı inceleyin

Not:Bu uygulama ExecuteExcel4Macro yöntemiyle veri almaktadır.

1-ana dosya ve diğer dosyalar aynı klasörde olmalı
2-veri alınacak dosyaların içinde mutlaka Sayfa1 sayfası olmalı
3-veri alınacak dosyalardaki A sutünun son satırını (BAĞ_DEĞ_DOLU_SAY)
ile bulunduğundan A sutünunda boş hücre olursa altdaki hücrelerdeki değerleri görmeye bilir.

 

[talebeyim]

:kafa::???:

Abi ekteki dosyayı inceleyebilirmisiniz, istediğim tam olarak bu

tek fark sheetlerden değil. Kapalı dosyalardan etoplayla alacak verileri.

Benim icin veri alım süresinin cok hızlı olması önemli exequte. yada ado farketmez.

 

[halit3]

:kafa::???:

Abi ekteki dosyayı inceleyebilirmisiniz, istediğim tam olarak bu

tek fark sheetlerden değil. Kapalı dosyalardan etoplayla alacak verileri.

Benim icin veri alım süresinin cok hızlı olması önemli exequte. yada ado farketmez.

Konu baya uzayacağa benziyor.
Benim alıntı yazımı lütfen okuyun örnek dosyalarınız hayali bire bir aynı olmalı yoksa kodlarla her seferinde yeniden uğraşmak gerekir.Ben bunun için genelde bu tip sorulara cevap vermekten kaçınıyorum.

Bu kodu denermisiniz.

Sub aktar()
Dim say(5000)
sut1 = Cells(1, 1).Value
a = MsgBox("DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo)
If a = vbNo Then
Exit Sub
End If
sat1 = 2
Range(Cells(1, 2), Cells(Rows.Count, Columns.Count)).Value = ""
Klasor = ThisWorkbook.Path
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files
If UCase(Right(Dosya.Name, 3)) = UCase("xls") Then
If ThisWorkbook.Name <> Dosya.Name Then
Kaynak1 = Dosya
yer = Mid(Kaynak1, 1, Len(Kaynak1) - Len(Dir(Kaynak1)))
deg = "'" & yer & "[" & Dir(Kaynak1) & "]" & x & "'!R"
Cells(1, 1).Value = yer
Cells(1, 2).Value = Dosya.Name
Cells(1, 3).Value = "=" & deg & 1 & "C" & 1
Cells(1, 3).Replace What:="=", Replacement:=""
alan1 = Cells(1, 3).Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
zaman = Mid(alan1, k + 1, yer)
End If
Next
Cells(1, 3).Value = zaman
sayfaadi = zaman
deg = "'" & Klasor & "\" & "[" & Dosya.Name & "]" & sayfaadi & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Application.ExecuteExcel4Macro("COUNTA('" & Klasor & "\" & "[" & Dosya.Name & "]" & sayfaadi & "'!C1)")
For j = 2 To 5
For r = 2 To sat
If LCase(Cells(j, 1).Value) = LCase(ExecuteExcel4Macro(deg & r & "C" & 1)) Then
Cells(j, sat1).Value = Cells(j, sat1).Value + ExecuteExcel4Macro(deg & r & "C" & 2)
If Cells(j, sat1).Value = 0 Then
Cells(j, sat1).Value = ""
End If
End If
Next r
Next j
say(sat1 - 1) = sayfaadi
sat1 = sat1 + 1
End If
End If
Next
For j = 1 To sat1 - 2
Cells(1, j + 1).Value = say(j)
Next
Cells(1, 1).Value = sut1
MsgBox "işlem tamam"
End Sub

 

[talebeyim]

Halit bey yanlış anladınız sanırım, Benim ilgilendiğim aslında size soru sorduğum ilk tablo.

Son gönderdiğim excel tablosu sadece konuyu size anlatabilmek icin hazırladım, O yüzden

tek fark sheetlerden değil.

demiştim.

Yani benim ilk istediğim neyse ve ilk koyduğum tablo neyse o sadece konuyu size anlatabilmek icin alternatif yollara basvuruyorum.
Son verdiğiniz kodu deniyorum çözüme ulaşamıyorum. Tek isteğim kapalı dosyadan toplam sonucu getirsin başka birşeyi değil.

Burada aktar dediğimde ne varsa getiriyor.

 

[halit3]

Halit bey yanlış anladınız sanırım, Benim ilgilendiğim aslında size soru sorduğum ilk tablo.

Son gönderdiğim excel tablosu sadece konuyu size anlatabilmek icin hazırladım, O yüzden demiştim.

Yani benim ilk istediğim neyse ve ilk koyduğum tablo neyse o sadece konuyu size anlatabilmek icin alternatif yollara basvuruyorum.
Son verdiğiniz kodu deniyorum çözüme ulaşamıyorum. Tek isteğim kapalı dosyadan toplam sonucu getirsin başka birşeyi değil.

Burada aktar dediğimde ne varsa getiriyor.

Aktar düğmesi ana dosyadaki A sutünundaki hücre değerini kapalı dosyanın A sutünundaki değerle aynı ise kapalı dosyadaki B sutünundaki hücrelerdeki değerleri topluyarak her bir dosyadaki sayfa için ayrı bir sutünda gösteriyor.

Burada kapalı dosyadaki bütün veriler gelmiyor eşitlik varsa geliyor.

 

[talebeyim]

Abi maalesef kafayı yeme durumuna geldim artık

If LCase(Cells(j, 1).Value) = LCase(ExecuteExcel4Macro(deg & r & "C" & 1)) Then
Cells(j, sat1).Value = Cells(j, sat1).Value + ExecuteExcel4Macro(deg & r & "C" & 2)
If Cells(j, sat1).Value = 0 Then
Cells(j, sat1).Value = ""
End If
End If
Next r

Kod burada sonsuz döngüye giriyor.
Halit bey ben bir yerde yanlışmı yapıyorum, verdiğiniz kodu bir öneğe eklermisiniz ?

 

[halit3]

Abi maalesef kafayı yeme durumuna geldim artık

If LCase(Cells(j, 1).Value) = LCase(ExecuteExcel4Macro(deg & r & "C" & 1)) Then
Cells(j, sat1).Value = Cells(j, sat1).Value + ExecuteExcel4Macro(deg & r & "C" & 2)
If Cells(j, sat1).Value = 0 Then
Cells(j, sat1).Value = ""
End If
End If
Next r

Kod burada sonsuz döngüye giriyor.
Halit bey ben bir yerde yanlışmı yapıyorum, verdiğiniz kodu bir öneğe eklermisiniz ?

Dosyalar ekde

 

[talebeyim]

Halit bey kod burada bir döngüye giriyor

If LCase(Cells(j, 1).Value) = LCase(ExecuteExcel4Macro(deg & r & "C" & 1)) Then

4,5 dk. sonra verdiği hata missmatch.

Yaptığım şey sadece ana isimli dosyayı açıp, getire basmak

 

[halit3]

Halit bey kod burada bir döngüye giriyor

If LCase(Cells(j, 1).Value) = LCase(ExecuteExcel4Macro(deg & r & "C" & 1)) Then

4,5 dk. sonra verdiği hata missmatch.

Yaptığım şey sadece ana isimli dosyayı açıp, getire basmak

Bende güzelcene çalışıyor görsel videoyu ekliyorum.

veri al

 

[talebeyim]

Buyrun bendeki çalışmasınıda size videoda gösterdim.

Tam kapatırken aklıma referanslar geldi, O bendeki aktif olan referanslarıda video'nun sonunda görüntüledim.

Umuyorum sorun budur.

 

[halit3]

Buyrun bendeki çalışmasınıda size videoda gösterdim.

Tam kapatırken aklıma referanslar geldi, O bendeki aktif olan referanslarıda video'nun sonunda görüntüledim.

Umuyorum sorun budur.

Kullanıcı profilinizde ofisin hangi sürüm kullandığınız yazmıyor.
Göndermiş olduğunuz videoda ofis 2003 kullanmadığınız anlaşılıyor.

Ofis 2003 de bu kodlar sorunsuz çalışıyor
ofis 2003'ün üstündeki sürümlerde çalışması için bütün dosyalarınızın uzantıları (xlsx) veya buna uyumlu olması gerekiyor.

Diğer taraftan

kodun bu bölümünü
If UCase(Right(Dosya.Name, 3)) = UCase("xls") Then

kırmızı yerleri değiştirin
If UCase(Right(Dosya.Name, 4)) = UCase("xlsx") Then

Not: dosyalarınızın uzantıları xlsx olmalı

 

[talebeyim]

Halit bey,

Hakkınızı helal edin lütfen, sabrınız ve âlakanız içinde ayrıca teşekkür ederim, işyerinde Office 2007 kullanıyorum, evde ise 2003 dediğiniz üzere uzantıyı yaptığım takdirde sorun çözüldü, elinize ve zihninize sağlık.

Ama maalesef buda işimi görmedi O kadar uğraş verilmesine rağmen okadar cok moralim bozulduki anlatamam (

Dört farklı dosyadan veri çektiğini biliyorsunuz Dosyanın en küçüğü 3000 satır. en fazla olan dosya ise 9.262 satır.

Ben sadece 3.000 olan satırlık veriyi çekmek istedim maalesef 8 dk. geçmesine rağmen halen kod çalışıyor (

O kadar yavas calısıyorki Ne yapacağımı bilemedim artık.
Muhtemelen eskiden olduğu gibi fonksiyonlarla devam edeceğim

Tekrar Teşekkür ederim zaman ayırdığınız için.

 

[halit3]

Halit bey,

Hakkınızı helal edin lütfen, sabrınız ve âlakanız içinde ayrıca teşekkür ederim, işyerinde Office 2007 kullanıyorum, evde ise 2003 dediğiniz üzere uzantıyı yaptığım takdirde sorun çözüldü, elinize ve zihninize sağlık.

Ama maalesef buda işimi görmedi O kadar uğraş verilmesine rağmen okadar cok moralim bozulduki anlatamam (

Dört farklı dosyadan veri çektiğini biliyorsunuz Dosyanın en küçüğü 3000 satır. en fazla olan dosya ise 9.262 satır.

Ben sadece 3.000 olan satırlık veriyi çekmek istedim maalesef 8 dk. geçmesine rağmen halen kod çalışıyor (

O kadar yavas calısıyorki Ne yapacağımı bilemedim artık.
Muhtemelen eskiden olduğu gibi fonksiyonlarla devam edeceğim

Tekrar Teşekkür ederim zaman ayırdığınız için.

Buda 20. mesaj son olsun 3000 veride bu yöntem çok uzun bir zaman alır.
Öneri Levent Beyin yöntemiyle verileri sayfaya alın sonra yardımcı başka bir sayfadada formüllerle yapmaya çalışın belki bu yöntemle daha hızlı verileri alırsınız.
Size iyi çalışmalar diliyorum.