ADO ile aynı anda bir çok sayfadan toplatarak veri alma

tamer42 · 13 Ekim 2022

Merhaba,
Ekli dosyada, her biri ayrı birer sayfada olmak üzere 3 adet Firmanın (A, B, C ) Hesap bakiye bilgileri mevcut,

"İcmal" sayfasında ise 3 firmayı ve Toplam bakiyeyi anda anda gösteren tablo mevcut,

Aşağıdaki 1. kod ile Hesap bilgilerini "Rapor" sayfasına alt-alta alabiliyoruz, Benim istediğim ise İcmal Tablosunda olduğu gibi tek seferde toplam Bakiye değerleri toplatarak getirmesi;

Bunun için 2 defa işlem yapıyorum:
1 nolu kod ile "Rapor" sayfasında verileri alt-alta düzenledikten sonra; "Rapor2" dosyada 2. kod ile toplam değerleri özet olarak alabiliyorum.

burada aslında "Rapor" sayfasını yardımcı sayfa olarak kullanmaktayım, buna gerek kalmadan 1. ve 2. kodu tek seferde çalıştırarak sonucu doğrudan "Rapor2" sayfasına getirmesi sağlanabilir mi?

1.

Kod:

For Each ws In wb.Worksheets

If ws.Name Like "Firma*" Then

    Tbl = "[" & ws.Name & "$]"
      
    sorgu = "Select HESAP, BAKİYE from " & Tbl
   
    Set RS = Con.Execute(sorgu)
   
    son = Sht.Cells(Sht.Rows.Count, 1).End(3).Row + 1
   
    Sht.Range("A" & son).CopyFromRecordset RS

End If

Set RS = Nothing

Next ws

- - - - - - - -
2.

Kod:

  sorgu = "Select HESAP, SUM(BAKİYE) as Toplam from [Rapor$] GROUP BY HESAP"
   Set RS = Con.Execute(sorgu)
   
    Sht.Range("A2").CopyFromRecordset RS

ilginiz için şimdiden teşekkürler,
iyi akşamlar.

veyselemre · 14 Ekim 2022

Kod:

Sub firma_Hesap()

    Dim Con As Object, rs As Object, _
    ws As Worksheet, Sht As Worksheet, _
    sorgu$, tbl$, son&, x&, baslik

    Set Con = VBA.CreateObject("adodb.Connection")

    Set Sht = Sheets("İCMAL")

    Sht.Cells.ClearContents

    Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
             ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

    sorgu = "TRANSFORM SUM(BAKİYE) SELECT HESAP, SUM(BAKİYE) AS TOPLAM FROM ( "

    For Each ws In Worksheets

        If ws.Name Like "Firma*" Then

            tbl = "[" & ws.Name & "$] "
      
            sorgu = sorgu & " SELECT HESAP, BAKİYE,'" & ws.Name & "' AS FİRMA FROM  " & tbl & " UNION ALL "
    
        End If
            
    Next ws
        
    sorgu = WorksheetFunction.Trim(sorgu)
    sorgu = Left(sorgu, Len(sorgu) - 10)
    sorgu = sorgu & ") TBL GROUP BY TBL.HESAP ORDER BY TBL.HESAP PIVOT TBL.FİRMA"
        
    Set rs = Con.Execute(sorgu)
    
    son = Sht.Cells(Sht.Rows.Count, 1).End(3).Row + 1
    
    Sht.Range("A" & son).CopyFromRecordset rs
    
    x = 1
    For Each baslik In rs.Fields
        Sht.Cells(1, x).Value = baslik.Name
        Sht.Cells(1, x).Font.Bold = True
        x = x + 1
    Next baslik

    Set rs = Nothing

End Sub

tamer42 · 14 Ekim 2022

veyselemre' Alıntı:

Kod:

Sub firma_Hesap()

    Dim Con As Object, rs As Object, _
    ws As Worksheet, Sht As Worksheet, _
    sorgu$, tbl$, son&, x&, baslik

    Set Con = VBA.CreateObject("adodb.Connection")

    Set Sht = Sheets("İCMAL")

    Sht.Cells.ClearContents

    Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
             ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

    sorgu = "TRANSFORM SUM(BAKİYE) SELECT HESAP, SUM(BAKİYE) AS TOPLAM FROM ( "

    For Each ws In Worksheets

        If ws.Name Like "Firma*" Then

            tbl = "[" & ws.Name & "$] "
     
            sorgu = sorgu & " SELECT HESAP, BAKİYE,'" & ws.Name & "' AS FİRMA FROM  " & tbl & " UNION ALL "
   
        End If
           
    Next ws
       
    sorgu = WorksheetFunction.Trim(sorgu)
    sorgu = Left(sorgu, Len(sorgu) - 10)
    sorgu = sorgu & ") TBL GROUP BY TBL.HESAP ORDER BY TBL.HESAP PIVOT TBL.FİRMA"
       
    Set rs = Con.Execute(sorgu)
   
    son = Sht.Cells(Sht.Rows.Count, 1).End(3).Row + 1
   
    Sht.Range("A" & son).CopyFromRecordset rs
   
    x = 1
    For Each baslik In rs.Fields
        Sht.Cells(1, x).Value = baslik.Name
        Sht.Cells(1, x).Font.Bold = True
        x = x + 1
    Next baslik

    Set rs = Nothing

End Sub

Veysel Hocam çok teşekkürler, emeğinize yüreğinize sağlık,

Kod:

sorgu = "TRANSFORM SUM(BAKİYE) SELECT HESAP, SUM(BAKİYE) AS TOPLAM FROM ( "

satırının anlamını açıklamnız mümkün müdür?

tamer42 · 14 Ekim 2022

Veysel Hocam çok teşekkürler, emeğinize yüreğinize sağlık,

farklı sayfalar yerine; farklı dosyalarda "veri" almak için sizin verdiğiniz kod üzerinde aşağıdaki düzenlemeleri yaptım; ama sorgu satırında hata veriyor.

Hata neden kaynaklanıyor? Nasıl çözebilirim, veri alıncak Örnek dosya ektedir.

tekrar teşekkürler,

Kod:

Sub firma_Hesap2()
Dim wb As Workbook
    Dim Con As Object, rs As Object, _
    ws As Worksheet, Sht As Worksheet, _
    sorgu$, tbl$, son&, x&, baslik, _
    arrFile(), filee, i As Byte, _
    yol As String, mypath As String
    

    Set wb = ThisWorkbook

    mypath = wb.Path
    
    yol = wb.FullName


    Set Con = VBA.CreateObject("adodb.Connection")

    Set Sht = Sheets("Rapor3")
Sht.Cells.ClearContents
 
    file1 = "A Şirketi(1).xlsx"
     file2 = "B Şirketi(2).xlsx"
      file3 = "C Şirketi(3).xlsx"
      
ReDim arrFile(1 To 3) As Variant
arrFile = Array(file1, file2, file3)

    Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
             yol & ";extended properties=""Excel 12.0;hdr=yes"""

    sorgu = "TRANSFORM SUM(BAKİYE) SELECT HESAP, SUM(BAKİYE) AS TOPLAM FROM ( "

    For i = LBound(arrFile) To UBound(arrFile)
    
    firma = Left(arrFile(i), Len(arrFile(i)) - 5)

    If firma <> "" Then
    
        myFile = mypath & "\" & arrFile(i)
        
            tbl = "[" & myFile & "].[veri$]"
      
            sorgu = sorgu & " SELECT HESAP, BAKİYE,'" & firma & "' AS FİRMA FROM " & [" & myFile & "].[veri$] & " UNION ALL "
    
        End If
            
    Next i
        
    sorgu = WorksheetFunction.Trim(sorgu)
    sorgu = Left(sorgu, Len(sorgu) - 10)
    sorgu = sorgu & ") TBL GROUP BY TBL.HESAP ORDER BY TBL.HESAP PIVOT TBL.FİRMA"
        
    Set rs = Con.Execute(sorgu)
    
    son = Sht.Cells(Sht.Rows.Count, 1).End(3).Row + 1
    
    Sht.Range("A" & son).CopyFromRecordset rs
    
    x = 1
    For Each baslik In rs.Fields
        Sht.Cells(1, x).Value = baslik.Name
        Sht.Cells(1, x).Font.Bold = True
        x = x + 1
    Next baslik

    Set rs = Nothing

End Sub

Haluk · 14 Ekim 2022

Alternatif;

.

tamer42 · 14 Ekim 2022

Haluk' Alıntı:
Alternatif;

.

Haluk Hocam çok teşekkür ederim, emeğinize sağlık
HESAP alanı yanında TANIM alanını da getirmek için sorguyu aşağıdaki şekilde düzenledim ama; olmadı
nerede hata yapıyor olabilirim.
iyi çalışmalar.

Kod:

    strSQL = " Select A.[HESAP], A.[TANIM], Sum(A.[BAKİYE]) As [BAKİYE] From " & _
             " (Select [HESAP],[TANIM], [BAKİYE] From [" & dataFile1 & "].[Veri$] " & _
             " Union All " & _
             " Select [HESAP],[TANIM], [BAKİYE] From [" & dataFile2 & "].[Veri$] " & _
             " Union All " & _
             " Select [HESAP],[TANIM], [BAKİYE] From [" & dataFile3 & "].[Veri$]) As A Group By A.[HESAP], A.[TANIM]"

veyselemre · 14 Ekim 2022

tamer42' Alıntı:
HESAP alanı yanında TANIM alanını da getirmek için sorguyu aşağıdaki şekilde düzenledim ama; olmadı
nerede hata yapıyor olabilirim.

Veri aldığınız dosyalarda TANIM alanının tümü mevcut mu?

Haluk · 14 Ekim 2022

tamer42' Alıntı:
Haluk Hocam çok teşekkür ederim, emeğinize sağlık
HESAP alanı yanında TANIM alanını da getirmek için sorguyu aşağıdaki şekilde düzenledim ama; olmadı
nerede hata yapıyor olabilirim.
iyi çalışmalar.

5 No'lu mesaj ekindeki dosyaları revize ettim. İncelersiniz....

.

tamer42 · 14 Ekim 2022

veyselemre' Alıntı:
Veri aldığınız dosyalarda TANIM alanının tümü mevcut mu?

TANIM Hepsinde mevcut Veysel Hocam

Haluk · 14 Ekim 2022

5 No'lu mesaj ekindeki dosyaları revize ettim. İncelersiniz....

.

tamer42 · 14 Ekim 2022

Haluk' Alıntı:
5 No'lu mesaj ekindeki dosyaları revize ettim. İncelersiniz....

.

Haluk Hocam ekli hata mesajını alıyorum; başka bir ayar mı yapılması gerekiyor acaba?

Haluk · 14 Ekim 2022

Birşeyleri yanlış yapıyorsunuz..... şimdi kontrol ettim, bir hata yok.

Diğer tüm dosyaları bilgisayardan silin, ekli RAR dosyasını bilgisayarda masaüstünde falan bir yere açın. Sonra Rapor.xlsm dosyasını açıp, makroyu çalıştırın.

.

tamer42 · 14 Ekim 2022

Haluk' Alıntı:
Birşeyleri yanlış yapıyorsunuz..... şimdi kontrol ettim, bir hata yok.

Diğer tüm dosyaları bilgisayardan silin, ekli RAR dosyasını bilgisayarda masaüstünde falan bir yere açın. Sonra Rapor.xlsm dosyasını açıp, makroyu çalıştırın.

.

Tamamdır Haluk Hocam, ben önceki kaynak dosyalarda denemişim, her şey için çok teşekürler;

tamer42 · 15 Ekim 2022

tamer42' Alıntı:
Tamamdır Haluk Hocam, ben önceki kaynak dosyalarda denemişim, her şey için çok teşekürler;

Haluk Hocam merhaba,

ADO bağlantısı ile wifi ağındaki paylaşılmış bir dosyayı diğer makinelerden bilgi çekmeye çalışırken; hata veriyor.
Nasıl bir çözüm üretilebilir?

DefaultDir=" & myPath
sanırsam bu satırdan kaynaklanıyor

teşekkürler,

Kod:

    Set WB = ThisWorkbook
    Set WS = WB.ActiveSheet
    
    myPath = WB.Path

    dataFile1 = "\\192.168.1.142\Barkod-3\Barkod.xlsm"
    dataFile2 = "\\192.168.1.124\Barkod-2\Parekende.xlsm"
    dataFile3 = "\\192.168.1.119\Barkod-1\Barkod.xlsm"
    
    On Error Resume Next
        WS.ListObjects("Report_" & WS.Name).Delete
    On Error GoTo 0
    
    strSource = "ODBC;DSN=Excel Files;DBQ=" & myFile & ";DefaultDir=" & myPath & _
                ";DriverId=1046;MaxBufferSize=2048;PageTimeout=5;"

ADO ile aynı anda bir çok sayfadan toplatarak veri alma

tamer42

Destek Ekibi

Ekli dosyalar

veyselemre

Özel Üye

tamer42

Destek Ekibi

tamer42

Destek Ekibi

Ekli dosyalar

Haluk

Özel Üye

Ekli dosyalar

tamer42

Destek Ekibi

veyselemre

Özel Üye

Haluk

Özel Üye

tamer42

Destek Ekibi

Haluk

Özel Üye

tamer42

Destek Ekibi

Ekli dosyalar

Haluk

Özel Üye

Ekli dosyalar

tamer42

Destek Ekibi

tamer42

Destek Ekibi

Ekli dosyalar