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 FileName As String
    Dim FullPath As String
    Dim YearNo As Long
    Dim Aylar As Variant
    Dim Ay As Variant
    Dim Sql As String
    Dim ArrOut()
    Dim R As Long
    Dim SonSatir As Long

    Set ws = ThisWorkbook.Worksheets("Tahsialat")

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

    If TenantName = "" Then
        MsgBox "Kiracı adı bulunamadı.", vbExclamation
        Exit Sub
    End If

    FolderPath = ThisWorkbook.Path & "\"

    Aylar = Array("Ocak", "Şubat", "Mart", "Nisan", _
                  "Mayıs", "Haziran", "Temmuz", _
                  "Ağustos", "Eylül", "Ekim", _
                  "Kasım", "Aralık")

    ReDim ArrOut(1 To 1000, 1 To 3)

    R = 0

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

        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 & "$C:I] " & _
                      "WHERE F3='" & Replace(TenantName, "'", "''") & "'"

                Set Rs = Conn.Execute(Sql)

                If Err.Number = 0 Then
                    Do Until Rs.EOF
                        If IsDate(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) = Rs.Fields(1).Value   'Tutar
                                ArrOut(R, 2) = 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
        End If
    Next YearNo

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

    If R > 0 Then
        ReDim Preserve ArrOut(1 To R, 1 To 3)
        ws.Range("D38").Resize(R, 3).Value = ArrOut
        ws.Range("E38").Resize(R).NumberFormat = "dd.mm.yyyy"
        MsgBox R & " adet ödeme bulundu.", vbInformation
    Else
        MsgBox "Ödeme bulunamadı.", vbExclamation
    End If
End Sub