Başka Excel Dosyasından Veri Almak..

[tirEdsOuL]

D:\deneme klasörümde satışlar.xls ve aralık.xls adında iki farklı dosyam var, satışlar dosyama bütün kayıtları alıyorum ve Aralık Dosyama da satışlardaki sadece aralık ayına ait verileri getirtmek istiyorum. Forumda biraz araştırdım, ama bulduklarımdan bir sonuç alamadım.. Levent hocamızın forumda paylaşmış olduğu aşağıdaki kod ile uğraştım biraz ama sanırım Set rs = baglanti.Execute("[a2:e65536]") kısmında bir hata yapıyorum.. benim düzenlemeye çalıştığım kod da aşağıdadır.

Sub verial()
For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder("d:\test\").Files
Set baglanti = CreateObject("ADODB.Connection")
yol = "DRIVER={Microsoft Excel Driver (*.xls)};" & "DBQ=d:\test\" & dosya.Name
baglanti.Open yol
Set rs = baglanti.Execute("[a2:e65536]")
sonsat = [a65536].End(3).Row + 1
Cells(sonsat, "f") = dosya.Name
Cells(sonsat, "a").CopyFromRecordset rs
rs.Close
baglanti.Close
Next
End Sub

Düzenlemeye Çalıştığım hali

Sub Guncelle()
 
    Dim i As Long, sat As Long, c As Range
    Dim Adr As Variant, Sa As Worksheet
    
    For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder("d:\deneme\").Files
Set baglanti = CreateObject("ADODB.Connection")
yol = "DRIVER={Microsoft Excel Driver (*.xls)};" & "DBQ=d:\deneme\" & dosya.Name
baglanti.Open yol
Set Sa = baglanti.Execute("Satislar")
    
        
    Application.ScreenUpdating = False
    
    For i = Cells(Rows.Count, "G").End(xlUp).Row To 2 Step -1
        With Sa.Range("G:G")
          Set c = .Find(Cells(i, "G"), , xlValues, xlWhole)
            If Not c Is Nothing Then
              Adr = c.Address
                Do
                  If Sa.Cells(c.Row, "G") = "B" Then
                    Rows(i).Delete
                  End If
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            Else
                Rows(i).Delete
            End If
        End With
    Next i
 
    sat = Cells(Rows.Count, "G").End(xlUp).Row + 1
    For i = 2 To Sa.Cells(Rows.Count, "A").End(xlUp).Row
        If Sa.Cells(i, "G") = "B" Then
        Set c = Range("G:G").Find(Sa.Cells(i, "G"), , xlValues, xlWhole)
            If c Is Nothing Then
                If Format(Sa.Cells(i, "O"), "mm") = Format(Date, "mm") Then
                Cells(sat, "A") = sat - 2
                Cells(sat, "B") = Sa.Cells(i, "P")
                Cells(sat, "F") = Sa.Cells(i, "O")
                Cells(sat, "E") = Sa.Cells(i, "H")
                sat = sat + 1
                End If
            End If
        End If
    Next i
    
    Range("A2") = 1
    Range("A2").DataSeries xlColumns, xlLinear, xlDay, 1, sat - 2
 
    Set c = Nothing: Set Sa = Nothing
 
    Application.ScreenUpdating = True
 rs.Close
baglanti.Close
End Sub

Orjinal hali

Sub Guncelle()
 
    Dim i As Long, sat As Long, c As Range
    Dim Adr As Variant, Sa As Worksheet
    
    Set Sa = Sheets("Satislar")
    
    Application.ScreenUpdating = False
    
    For i = Cells(Rows.Count, "G").End(xlUp).Row To 2 Step -1
        With Sa.Range("G:G")
          Set c = .Find(Cells(i, "G"), , xlValues, xlWhole)
            If Not c Is Nothing Then
              Adr = c.Address
                Do
                  If Sa.Cells(c.Row, "G") = "B" Then
                    Rows(i).Delete
                  End If
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            Else
                Rows(i).Delete
            End If
        End With
    Next i
 
    sat = Cells(Rows.Count, "G").End(xlUp).Row + 1
    For i = 2 To Sa.Cells(Rows.Count, "A").End(xlUp).Row
        If Sa.Cells(i, "G") = "B" Then
        Set c = Range("G:G").Find(Sa.Cells(i, "G"), , xlValues, xlWhole)
            If c Is Nothing Then
                If Format(Sa.Cells(i, "O"), "mm") = Format(Date, "mm") Then
                Cells(sat, "A") = sat - 2
                Cells(sat, "B") = Sa.Cells(i, "P")
                Cells(sat, "F") = Sa.Cells(i, "O")
                Cells(sat, "E") = Sa.Cells(i, "H")
                sat = sat + 1
                End If
            End If
        End If
    Next i
    
    Range("A2") = 1
    Range("A2").DataSeries xlColumns, xlLinear, xlDay, 1, sat - 2
 
    Set c = Nothing: Set Sa = Nothing
 
    Application.ScreenUpdating = True
 
End Sub

 

[Levent Menteşoğlu]

Getirmek istediğiniz verilerden bir örneği aralık.xls dosyasına eklermisiniz.

 

[tirEdsOuL]

bunun için satışlar.xls dosyasındaki aralık sayfasına bakabilirsiniz hocam.. kodun orjinal hali sayfalarda çalışıyor, ama ben o sayfalar ay ay olarak ayrı dosyalar halinde tutacağım..

 

[tirEdsOuL]

Günceldir.