Soru Kira takip tablosu

[mars2]

İyi Günler;

Excel çalışma kitabımında Tahsilat sayfası bulunmaktadır. C24 hücresinde kiracının adı soyadı, C29 hücresinde aylık kira bedeli, C31 hücresinde kira başlangıç tarihi, C32 hücresinde ise kira bitiş tarihi bulunmaktadır. C37 ile C49 hücrelerinde 1 yıllık döneme ait kira aylık tablosu bulunmaktadır. D37, E37 ve F37 hücrelerinden başlamak o o döneme ait kiracı tarafından yatıran kira bedelleri, tarih ve açıklaması almak istiyorum. Bu verileri aynı klasör içinde her yıla ait tahsil edilen kiraları kayıt altına almaktayım. Yılla ait çalışma kitabında, her ay için ayrı sayfa bulunmakta ve C sutununda isim, D sutunda Yatırılan tutar, E Sutunda ise tarih ve I sutununda da açıklama bulunmaktadır. Örneğin; C24 hücresinde Mehmet Can, C29 hücresinde aylık 1.500,00 ₺ C31 hücresinde 15.02.2025, C32 hücresinde 14.02.2026 tarihi bulunmaktadır. Buna göre Mehmet Can'ın 15.02.2025 ila 14.02.2026 tarihleri arasındaki yatırdığı tutarları, tarih ve açıklama bölümü yazdıran makro nedir.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub KiralariGetir_ADO()
    Dim ws As Worksheet
    Dim TenantName As String
    Dim StartDate As Date
    Dim EndDate As Date
    Dim Conn As Object
    Dim Rs As Object
    Dim FolderPath As String
    Dim FullPath As String
    Dim YearNo As Long
    Dim Ay As Variant
    Dim Aylar As Variant
    Dim SQL As String
    Dim ArrOut() As Variant
    Dim WriteArr() As Variant
    Dim R As Long
    Dim i As Long

    Set ws = ThisWorkbook.Worksheets("Tahsilat")

    TenantName = Trim$(ws.Range("C24").Value)

    If Len(TenantName) = 0 Then
        MsgBox "C24 hücresinde kiracı adı bulunamadı.", vbExclamation
        Exit Sub
    End If

    StartDate = ws.Range("C31").Value
    EndDate = ws.Range("C32").Value

    FolderPath = ThisWorkbook.Path & "\"

    Aylar = Array("ocak", "subat", "mart", "nisan", _
                  "mayıs", "haziran", "temmuz", _
                  "agustos", "eylül", "ekim", _
                  "kasım", "aralık")

    ReDim ArrOut(1 To 1000, 1 To 3)

    R = 0

    For YearNo = Year(StartDate) To Year(EndDate)
        FullPath = FolderPath & YearNo & ".xlsx"

        If Dir(FullPath) <> "" Then
            Set Conn = CreateObject("ADODB.Connection")

            Conn.Open _
                "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & FullPath & ";" & _
                "Extended Properties=""Excel 12.0 Xml;HDR=No;IMEX=1"";"

            For Each Ay In Aylar
                On Error Resume Next

                SQL = "SELECT F3,F4,F5,F9 " & _
                      "FROM [" & Ay & "$A:I] " & _
                      "WHERE F3='" & Replace(TenantName, "'", "''") & "'"

                Set Rs = Conn.Execute(SQL)

                If Err.Number = 0 Then
                    Do Until Rs.EOF
                        'Debug.Print CDate(Rs.Fields(2).Value)
                        If IsDate(CDate(Rs.Fields(2).Value)) Then
                            If CDate(Rs.Fields(2).Value) >= StartDate _
                            And CDate(Rs.Fields(2).Value) <= EndDate Then
                                R = R + 1
                                ArrOut(R, 1) = CDbl(Rs.Fields(1).Value)   ' Tutar
                                ArrOut(R, 2) = CDate(Rs.Fields(2).Value)  ' Tarih
                                ArrOut(R, 3) = Rs.Fields(3).Value         ' Açıklama
                            End If
                        End If
                        Rs.MoveNext
                    Loop
                    Rs.Close
                End If

                Err.Clear
                On Error GoTo 0
            Next Ay

            Conn.Close
            Set Conn = Nothing
        End If
    Next YearNo

    ws.Range("D38:G49").ClearContents

    If R > 0 Then
        ReDim WriteArr(1 To R, 1 To 3)

        For i = 1 To R
            WriteArr(i, 1) = ArrOut(i, 1)
            WriteArr(i, 2) = ArrOut(i, 2)
            WriteArr(i, 3) = ArrOut(i, 3)
        Next i

        ws.Range("D38").Resize(R, 3).Value = WriteArr
        ws.Range("D38").Resize(R).NumberFormat = "#,##0.00 " & ChrW(8378)
        ws.Range("E38").Resize(R).NumberFormat = "dd.mm.yyyy"

        MsgBox R & " adet ödeme bulundu.", vbInformation
    Else
        MsgBox "Belirtilen dönemde ödeme bulunamadı.", vbExclamation
    End If
End Sub

 

[mars2]

Sayın Korhan bey;
İlginiz için teşekkürler. ancak isim yazdığımda ve öde yapmasına rağmen ödeme bulunamadı mesajı gelmektedir.

 

[Korhan Ayhan]

Bir adet kaynak dosya paylaşırsanız deneme yapabilirim.

 

[mars2]

Sayın Korhan bey;
Örnek ekte olup her yil için farklı çalışma kitaplarında bulunmaktadır.

 

[Korhan Ayhan]

Paylaştığınız kaynak dosyada ay isimleri küçük harfle yazılmış ve bazılarında farklı yazımlar var (subat-agustos ....)

Önerdiğim kodu buna göre revize ettim. Tekrar deneyiniz.

 

[mars2]

Sayın Korhan bey;
İlginiz için teşekkürler, Örnek uygulamada kod sorunsuz çalıştı ancak, kendi uygulamamda
If IsDate(CDate(Rs.Fields(2).Value)) Then hata verdi. Kira başlangıç tarihi C31 hücresinde 2025, bitiş yılı C32 hücresinde ve 2026