Ado ile birkaç dosyadan koşullu veri çekme

[hüseyintok]

Merhaba Ado ile veri çekme konusunu inceledim fakat koşullu veri çekme konusunda çok fazla örnek yok. Bana yardımcı olacağınızı ve birçok arkadaşımın da faydalanacağını düşündüğüm sorunum için siz değerli üstatlardan yardım istiyorum.
3 farklı dosyam var ekte ve 3 dosyada da şirket koduna göre veri dosyamda olan şirket kodu ile eşleşen verileri ilgili aylara dosyalardan çekmek istiyorum.
Örnek dosyamı ekliyorum. Şimdiden teşekkürler

 

[Korhan Ayhan]

Merhaba,

KAYNAK tablolarda aylar sağ tarafa doğru değilde liste mantığı gibi alt alta satırlarda olursa konsolide daha kolay olabilir gibi geldi.

 

[hüseyintok]

Merhaba Korhan bey, Önerinizde şöyle bir sıkıntı yaşarım. Max 12 ay var ama müşteri sayım şuan için 1500-2000 arasında ve giderek artıyor. Veri dosyasında filitre ile müşteri detaylarına bakabiliyorum ama dediğiniz gibi müşteriyi sağ tarafa, ayları dikey yaparsak filtrelemede zorluk yaşarım. ama tek çözüm bu şekilde olmak zorunda ise hiç data olmamasından iyidir.

 

[Korhan Ayhan]

Elbette tablolarının olduğu haliyle de çözüm üretebilecek üyelerimiz olabilir.

ADO işlemlerinde kaynak tablolar veritabanı mantığında olduğunda işler oldukça kolaylaşıyor.

Dosyalarınızın bu haliyle ADO yerine gizli olarak açılıp verilerin alınması daha mantıklı geliyor.

 

[dilek.gumus]

Bu konu benim sorunumu da çözer. Umarım biri yardımcı olur.

 

[hüseyintok]

Elbette tablolarının olduğu haliyle de çözüm üretebilecek üyelerimiz olabilir.

ADO işlemlerinde kaynak tablolar veritabanı mantığında olduğunda işler oldukça kolaylaşıyor.

Dosyalarınızın bu haliyle ADO yerine gizli olarak açılıp verilerin alınması daha mantıklı geliyor.

Korhan bey dediğiniz gibi çözüm için yardımcı olurmusunuz?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Private Sub CommandButton1_Click()
    Dim Zaman As Double, Yol As String, Dosya As String
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet
    Dim Son As Long, Veri As Range, Ay As Range
    Dim Aranan_Ay As Range, Sirket_Kodu As Range
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("aktarım")
    
    S1.Range("F4:Q" & S1.Rows.Count).ClearContents
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya = Dir(Yol & "*.xls")
    
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    
    While Dosya <> ""
        If Yol & Dosya <> ThisWorkbook.FullName Then
            Set K2 = GetObject(Yol & Dosya)
            Set S2 = K2.Sheets("Sheet1")
            
            For Each Veri In S1.Range("C4:C" & Son)
                If Veri.Value <> "" Then
                    Set Sirket_Kodu = S2.Cells.Find(Veri.Value, , , xlWhole)
                    If Not Sirket_Kodu Is Nothing Then
                        For Each Ay In S1.Range("F3:Q3")
                            If Ay.Value <> "" Then
                                Set Aranan_Ay = S2.Cells.Find(Ay.Value, , , xlWhole)
                                If Not Aranan_Ay Is Nothing Then
                                    S1.Cells(Veri.Row, Ay.Column) = _
                                    S1.Cells(Veri.Row, Ay.Column) + _
                                    S2.Cells(Sirket_Kodu.Row, Aranan_Ay.Column)
                                End If
                            End If
                        Next
                    End If
                End If
            Next
            K2.Close 0
        End If
        Dosya = Dir
    Wend
    
    Set Sirket_Kodu = Nothing
    Set Aranan_Ay = Nothing
    Set S2 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
    
    Application.Calculation = -4105
    Application.ScreenUpdating = 1
    
    MsgBox "Veri aktarımı tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[hüseyintok]

Deneyiniz.

Option Explicit

Private Sub CommandButton1_Click()
    Dim Zaman As Double, Yol As String, Dosya As String
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet
    Dim Son As Long, Veri As Range, Ay As Range
    Dim Aranan_Ay As Range, Sirket_Kodu As Range
   
    Zaman = Timer
   
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
   
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("aktarım")
   
    S1.Range("F4:Q" & S1.Rows.Count).ClearContents
   
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya = Dir(Yol & "*.xls")
   
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
   
    While Dosya <> ""
        If Yol & Dosya <> ThisWorkbook.FullName Then
            Set K2 = GetObject(Yol & Dosya)
            Set S2 = K2.Sheets("Sheet1")
           
            For Each Veri In S1.Range("C4:C" & Son)
                If Veri.Value <> "" Then
                    Set Sirket_Kodu = S2.Cells.Find(Veri.Value, , , xlWhole)
                    If Not Sirket_Kodu Is Nothing Then
                        For Each Ay In S1.Range("F3:Q3")
                            If Ay.Value <> "" Then
                                Set Aranan_Ay = S2.Cells.Find(Ay.Value, , , xlWhole)
                                If Not Aranan_Ay Is Nothing Then
                                    S1.Cells(Veri.Row, Ay.Column) = _
                                    S1.Cells(Veri.Row, Ay.Column) + _
                                    S2.Cells(Sirket_Kodu.Row, Aranan_Ay.Column)
                                End If
                            End If
                        Next
                    End If
                End If
            Next
            K2.Close 0
        End If
        Dosya = Dir
    Wend
   
    Set Sirket_Kodu = Nothing
    Set Aranan_Ay = Nothing
    Set S2 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
   
    Application.Calculation = -4105
    Application.ScreenUpdating = 1
   
    MsgBox "Veri aktarımı tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

çok teşekkürler Kayhan bey,
Yalnız dosyalar farklı klosörlerde olduğu işin macro da Yol ve dosya kısımlarını nasıl güncelleyebilirim. örneğin;
Kaynak1 c:/program1/kaynak1.xls
kaynak2 d:/value/kaynak2.xls
kaynak3 e:/pro/kaynak3.xls
Yol = ThisWorkbook.Path & Application.PathSeparator
Dosya = Dir(Yol & "*.xls")

 

[Korhan Ayhan]

Bu işlemin en kolay yolu kaynak dosyaları tek bir klasör altına almaktır.