• Web sitemize destek olmak, Hazır Excel Dosyaları indirmek ve sitemizi reklamsız kullanmak için VIP Üyelik Satın alabilirsiniz.
    Hesabını VIP Üyeliğe Yükselt

Soru ADO ile Diğer Dosyalardan Veri Almak

merakli

VIP
VIP
Kullanıcı
Versiyon
  1. Excel 2019
Sürüm
  1. 64 bit
Dil
  1. Türkçe

Reputation:

Merhaba,
Rapor isimli excel dosyama Test 1 isimli klasör içinde bulunan excel dosyalarından resimde anlattığım verileri nasıl alabiliriz?



soru.png
 

Ekli dosyalar

  • ADO.rar
    288.4 KB · Görüntüleme: 11

MESKO

Yeni Üye
Kullanıcı
Versiyon
  1. Excel 2003
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

İlgili dosyaları inner join ile birleştirip oluşan geçici rapordan ilgili alanlar alınabilir.
Fakat zaman alıcı bir işlem uygun bir zamanda bakmaya çalışırım.
 

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Merhaba @merakli .

ADO yöntemi yerine, kasik yöntem (kaynak begeyi aç, verileri bulup yerine yaz, kaynak belgeyi kapat) kullanıldı.

-- Asıl begeyle kaynak belgelerin bulunduğu klasörün aynı klasörde olduğu varsayıldı. Klasör ismi A1 hücresinden alınır.
-- Kaynak belgelerdeki D/Y/B sütunlarının her zaman O, P ve Q sütunları olduğu varsayıldı.
-- Benzersizlik garantisi olarak C sütunu (öğrenci no) kullanıldı, öğrenci numarasına göre eşleşme arandı.

C#:
Sub TEST_BILGILERI_AL()
Set a = ThisWorkbook.Sheets("ADO")
ason = a.Cells(Rows.Count, 3).End(3).Row
a.Range("E5:V" & ason).ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
kls = ThisWorkbook.Path & "\" & a.[A1].Text
ders = Array("Matematik", "Türkçe", "Fen", "İnkılap", "İngilizce", "Din")
tno = Split(a.[A1].Text, " ")(1) & "_"
For asut = LBound(ders) To UBound(ders)
    Workbooks.Open (kls & "\" & tno & ders(asut) & ".xlsm")
    Set t = Workbooks(tno & ders(asut) & ".xlsm").Sheets("Tüm")
    For sat = 5 To a.Cells(Rows.Count, 2).End(3).Row
        If WorksheetFunction.CountIf(t.[C:C], a.Cells(sat, 3)) > 0 Then
            tsat = WorksheetFunction.Match(a.Cells(sat, 3), t.[C:C], 0)
            a.Cells(sat, asut * 3 + 5) = t.Cells(tsat, 15)
            a.Cells(sat, asut * 3 + 6) = t.Cells(tsat, 16)
            a.Cells(sat, asut * 3 + 7) = t.Cells(tsat, 17)
        End If
    Next: Workbooks(tno & ders(asut) & ".xlsm").Close 0
Next: Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı..", vbInformation, "::.. ExcelDestek.Com ..::"
End Sub
 

merakli

VIP
VIP
Kullanıcı
Versiyon
  1. Excel 2019
Sürüm
  1. 64 bit
Dil
  1. Türkçe

Reputation:

@Ömer BARAN Bey Teşekkür Ederim.

Merhaba @merakli .

ADO yöntemi yerine, kasik yöntem (kaynak begeyi aç, verileri bulup yerine yaz, kaynak belgeyi kapat) kullanıldı.

-- Asıl begeyle kaynak belgelerin bulunduğu klasörün aynı klasörde olduğu varsayıldı. Klasör ismi A1 hücresinden alınır.
-- Kaynak belgelerdeki D/Y/B sütunlarının her zaman O, P ve Q sütunları olduğu varsayıldı.
-- Benzersizlik garantisi olarak C sütunu (öğrenci no) kullanıldı, öğrenci numarasına göre eşleşme arandı.

C#:
Sub TEST_BILGILERI_AL()
Set a = ThisWorkbook.Sheets("ADO")
ason = a.Cells(Rows.Count, 3).End(3).Row
a.Range("E5:V" & ason).ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
kls = ThisWorkbook.Path & "\" & a.[A1].Text
ders = Array("Matematik", "Türkçe", "Fen", "İnkılap", "İngilizce", "Din")
tno = Split(a.[A1].Text, " ")(1) & "_"
For asut = LBound(ders) To UBound(ders)
    Workbooks.Open (kls & "\" & tno & ders(asut) & ".xlsm")
    Set t = Workbooks(tno & ders(asut) & ".xlsm").Sheets("Tüm")
    For sat = 5 To a.Cells(Rows.Count, 2).End(3).Row
        If WorksheetFunction.CountIf(t.[C:C], a.Cells(sat, 3)) > 0 Then
            tsat = WorksheetFunction.Match(a.Cells(sat, 3), t.[C:C], 0)
            a.Cells(sat, asut * 3 + 5) = t.Cells(tsat, 15)
            a.Cells(sat, asut * 3 + 6) = t.Cells(tsat, 16)
            a.Cells(sat, asut * 3 + 7) = t.Cells(tsat, 17)
        End If
    Next: Workbooks(tno & ders(asut) & ".xlsm").Close 0
Next: Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı..", vbInformation, "::.. ExcelDestek.Com ..::"
End Sub
 
Üst