ADO ile Veri Çağırma,

[Utekiner]

Merhaba,

Açık ve kapalı olmak üzere iki adet dosyam bulunuyor. Kapalı çalışma kitabında A1 ile H1 sütunların arasında başlıklar ve alt satırlarında 50.000 veri mevcuttur.

Açık sayfamda A1 Sütununda Kapalı dosyadan aranması gereken veriler yer alıyor. (değişkenlik gösteriyor. Bazen 10 adet veri bazen 5000 adet veri oluyor.)

Açık sayfadaki değeri kapalı sayfanın A:A sütununda aramasını ve bulması durumunda B1ile H1 başlıklarına ait verileri aktarmasını istiyorum. Konu hakkında yardımcı olabilir misiniz. Aslında bu işlemi yaptığım kod var ama bu kod çok yavaş çalışmakta ve bazen hatalı değerleri getirmektedir.

https://s6.dosya.tc/server3/ubib6n/ADO.rar.html

 

[Ziynettin]

Dictionary metodu;

Dosyalar aynı klasörde olmalı.

Sub Kapalidan_Veri_Al()
yol = ThisWorkbook.Path
dosya = "Kapalı.xlsx"
Application.ScreenUpdating = False
GetObject (yol & "\" & dosya)
Set s1 = Workbooks(dosya).Sheets("Sayfa1")
son = s1.Cells(Rows.Count, 1).End(3).Row
a = s1.Range("A1:H" & son).Value
Windows(dosya).Visible = True
Workbooks(dosya).Close 0

Set dc = CreateObject("scripting.dictionary")
For i = 1 To UBound(a)
    krt = CStr(a(i, 1))
    dc(a(i, 1)) = i
Next i

Set s2 = Sheets("Sayfa1")
son = 0
son = s2.Cells(Rows.Count, 1).End(3).Row

b = s2.Range("A2:A" & son).Value
ReDim v(1 To UBound(b), 1 To 7)

For i = 1 To UBound(b)
    krt = CStr(b(i, 1))
    If dc.exists(b(i, 1)) Then
        For j = 1 To 7
            v(i, j) = a(dc(krt), j + 1)
        Next j
    End If
Next i

s2.[F2].Resize(UBound(b)).NumberFormat = "#,##0.00"
s2.[B2].Resize(UBound(b), 7) = v
Application.ScreenUpdating = True
MsgBox "İşlem Bitti...", vbInformation
End Sub

 

[Haluk]

ADO ile alternatif; (Dosyalar aynı klasörde olacak)

Sub Test()
'   Haluk - 05/07/2021
'   sa4truss@gmail.com
'   https://excelhaluk.blogspot.com/
    Dim WB1 As String, WB2 As String
    Dim strConnection As String
    Dim strQuery As String
    Dim objConnection As Object
    Dim objRecordSet As Object
 
    Range("B2:H" & Rows.Count) = Empty
 
    WB1 = ThisWorkbook.FullName
    WB2 = ThisWorkbook.Path & Application.PathSeparator & "Kapalı.xlsx"
 
    Set objConnection = CreateObject("ADODB.Connection")
 
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "User ID=Admin;" & _
                    "Data Source='" & ThisWorkbook.FullName & "';" & _
                    "Mode=Read;" & _
                    "Extended Properties=""Excel 12.0 Macro;"";"

    strQuery = _
        "SELECT [Malzeme Adı], [Gönderim Yeri], [Gönderim Palet No], [Gönderim Adeti], " & _
        "[Tutar], [Araç], [Sorumlu Kişi] FROM [Sayfa1$] " & _
        "IN '" & WB2 & "'[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=YES;'] " & _
        "WHERE [Malzeme No] IN " & _
        "(SELECT [Malzeme No] FROM [Sayfa1$] " & _
        "IN '" & WB1 & "'[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=YES;'])"
 
    objConnection.Open strConnection
    Set RS = objConnection.Execute(strQuery)
 
    Range("B2").CopyFromRecordset RS
 
    objConnection.Close
    Set RS = Nothing
    Set objConnection = Nothing
End Sub

.

 

[Erdem Akdemir]

Alternatif sorgu,

Sub duseyaraa()

    Range("B2:H" & Rows.Count).ClearContents
      
    Set con = VBA.CreateObject("adodb.Connection")
    yol = ThisWorkbook.Path & "\" & "Kapalı.xlsx"
    
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
      
    dtb = ThisWorkbook.Path & "\" & "Kapalı.xlsx"
    
    sorgu = "Select t2.[Malzeme Adı], t2.[Gönderim Yeri], t2.[Gönderim Palet No], t2.[Gönderim Adeti], " & _
        "t2.[Tutar], t2.[Araç], t2.[Sorumlu Kişi] FROM [Sayfa1$] as t1 left join " & _
        "[" & dtb & "].[Sayfa1$] as T2 " & _
        "on T1.[Malzeme No] = T2.[Malzeme No]"
        
    Set rs = con.Execute(sorgu)
    
    Range("B2").CopyFromRecordset rs
    
End Sub

 

[Utekiner]

Herkese çok teşekkür ederim. Kodların çalışma süresi şu şekildedir.

Haluk - 34 sn
Ziynettin - 17 sn
Erdem - 19 sn