Aylık Rapor Çekme

[Bahattin Sungur]

Sub RAPORLAMA()
Set s1 = Sheets("PLAN")
Set s2 = Sheets("URT RAPORU")
son = s1.Cells(Rows.Count, "E").End(3).Row
eski = WorksheetFunction.Max(9, s2.Cells(Rows.Count, "D").End(3).Row)
sonsut = s1.Cells(2, Columns.Count).End(xlToLeft).Column
s2.Range("D9:J" & eski).ClearContents
If s2.[L6] = "" Then Exit Sub
If IsDate(s2.[L6]) = False Then Exit Sub
If WorksheetFunction.CountIf(s1.[A3:NY3], s2.[L6]) = 0 Then
    MsgBox "Girilen tarihe ait veri bulunmamaktadır!", vbInformation
    Exit Sub
Else
    Application.ScreenUpdating = False
        sut = WorksheetFunction.Match(s2.[L6], s1.[A3:NY3], 0)
        Set con = VBA.CreateObject("adodb.Connection")
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
        sorgu = "select F5, F8, F11, F20, F" & sut & ",F23 from[plan$A4:IB" & son & "] where F" & sut & " is not null"
        Set rs = con.Execute(sorgu)
        s2.[E9].CopyFromRecordset rs
        yeni = WorksheetFunction.Max(9, Cells(Rows.Count, "E").End(3).Row)
        For i = 9 To yeni
            Cells(i, "D") = i - 8
        Next
    Application.ScreenUpdating = True
End If
End Sub

herkese kolay gelsin öncelikle arkadaşlar, ben bu kod ile kabaca özetlersek örnek olarak 1 satırında tarihler a sütununda firmalar yazan bır tablodan (satır sutuna takılmayın lutfen) rapor cekıyorum, mesela 31.07.2021 tarihinde firmalar için planlanan şeyler rapor sayfasında dırek onume gelıyor. ben bunu tarih arası yapmak istiyorum. mesela 28.07.2021-31.07.2021 yazdıgımda aralıkta planlanan her seyi cekmek istiyorum. Yardım edebilirseniz cok memnun olurum.Simdiden cok tesekkur ederım.

 

[YUSUF44]

Bu türden sorularda örnek dosya çok önemlidir, muhtemelen şimdiye kadar cevap almamanızın nedeni de dosya paylaşmamış olmanızdır.

Dosya olmadığı için kodları deneyemedim. Siz deneyin:

Sub RAPORLAMA()
Set s1 = Sheets("PLAN")
Set s2 = Sheets("URT RAPORU")
son = s1.Cells(Rows.Count, "E").End(3).Row
eski = WorksheetFunction.Max(9, s2.Cells(Rows.Count, "D").End(3).Row)
sonsut = s1.Cells(2, Columns.Count).End(xlToLeft).Column
s2.Range("D9:J" & eski).ClearContents
If s2.[L6] = "" Or s2.[M6] = "" Then Exit Sub
If IsDate(s2.[L6]) = False Or IsDate(s2.[M6]) = False Then Exit Sub
If s2.[L6] > s2.[M6] Then Exit Sub
For tarih = s2.[L6] To s2.[M6]
    If WorksheetFunction.CountIf(s1.[A3:NY3], tarih) = 0 Then
        MsgBox "Girilen tarihe ait veri bulunmamaktadır!", vbInformation
        Exit Sub
    Else
        Application.ScreenUpdating = False
            sut = WorksheetFunction.Match(tarih, s1.[A3:NY3], 0)
            Set con = VBA.CreateObject("adodb.Connection")
            con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
            ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
            sorgu = "select F5, F8, F11, F20, F" & sut & ",F23 from[plan$A4:IB" & son & "] where F" & sut & " is not null"
            Set rs = con.Execute(sorgu)
            s2.[E9].CopyFromRecordset rs
            yeni = WorksheetFunction.Max(9, Cells(Rows.Count, "E").End(3).Row)
            For i = 9 To yeni
                Cells(i, "D") = i - 8
            Next
        Application.ScreenUpdating = True
    End If
Next
End Sub