giderleştirme takibi

[Ali]

Aşağıda kodları dener misiniz.

Sub Düğme1_Tıkla()

    Dim dt As Worksheet, hsp As Worksheet
    Dim sene As Long, ayIndex As Long
    Dim son As Long, son2 As Long
    Dim basla As Long, hedefKolon As Long
    Dim kosul As Boolean
    Dim aylar As Variant
    Dim i As Long
    Dim sifre As String
    Dim degerC As Variant, degerD As Variant
    Dim sonB As Long, sonC As Long, sonD As Long
    Dim bxKolon As Long, byKolon As Long
    Dim satirMetni As String
    Dim aktarilsin As Boolean
    
    sifre = "karzarar.org "
    bxKolon = Columns("BX").Column
    byKolon = Columns("BY").Column
    
    On Error GoTo HataYakala
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set dt = ThisWorkbook.Worksheets("Data")
    Set hsp = ThisWorkbook.Worksheets("Hesaplama")
    
    hsp.Unprotect sifre
    dt.Unprotect sifre
    
    son = dt.Cells(dt.Rows.Count, "B").End(xlUp).Row + 1
    
    sonB = hsp.Cells(hsp.Rows.Count, "B").End(xlUp).Row
    sonC = hsp.Cells(hsp.Rows.Count, "C").End(xlUp).Row
    sonD = hsp.Cells(hsp.Rows.Count, "D").End(xlUp).Row
    son2 = WorksheetFunction.Max(sonB, sonC, sonD)
    
    sene = Val(hsp.Range("B12").Value)
    kosul = False
    
    aylar = Array("", "Ocak", "Şubat", "Mart", "Nisan", "Mayıs", "Haziran", _
                  "Temmuz", "Ağustos", "Eylül", "Ekim", "Kasım", "Aralık")
    
    ayIndex = 0
    For i = 1 To 12
        If Trim(CStr(hsp.Range("B13").Value)) = aylar(i) Then
            ayIndex = i
            Exit For
        End If
    Next i
    
    If ayIndex = 0 Then
        MsgBox "Ay bulunamadı. Hesaplama sayfasındaki B13 hücresini kontrol edin.", vbCritical
        GoTo Cikis
    End If
    
    If sene >= 2026 And sene <= 2033 Then
        kosul = True
        basla = 10 + ((sene - 2026) * 24) + ((ayIndex - 1) * 2)
    End If
    
    If kosul = False Then
        
        GoTo Cikis
    End If
    
    dt.Range("B" & son).Value = hsp.Range("J1").Value
    dt.Range("C" & son).Value = hsp.Range("B7").Value
    dt.Range("E" & son).Value = hsp.Range("D6").Value
    dt.Range("F" & son).Value = hsp.Range("K1").Value
    dt.Range("G" & son).Value = hsp.Range("D5").Value
    dt.Range("H" & son).Value = hsp.Range("N3").Value
    dt.Range("I" & son).Value = hsp.Range("D4").Value
    
    hedefKolon = basla
    
    For i = 13 To son2
        
        degerC = hsp.Cells(i, "C").Value   ' KKEG
        degerD = hsp.Cells(i, "D").Value   ' Prim Tutarı
        
        satirMetni = UCase(Trim(CStr(hsp.Cells(i, "B").Text)) & " " & _
                           Trim(CStr(hsp.Cells(i, "C").Text)) & " " & _
                           Trim(CStr(hsp.Cells(i, "D").Text)))
        
        aktarilsin = False
        
        ' 26. satırı atla
        ' Genel Toplam geçen satırı atla
        If i <> 26 And InStr(1, satirMetni, "GENEL TOPLAM", vbTextCompare) = 0 Then
            
            ' C veya D doluysa satır aktarılsın
            If Not IsError(degerC) Then
                If Trim(CStr(degerC)) <> "" Then aktarilsin = True
            End If
            
            If Not IsError(degerD) Then
                If Trim(CStr(degerD)) <> "" Then aktarilsin = True
            End If
            
            If aktarilsin = True Then
                
                If hedefKolon <> bxKolon And hedefKolon + 1 <> byKolon Then
                    
                    ' D sütunu
                    If Not IsError(degerD) Then
                        If Trim(CStr(degerD)) <> "" Then
                            dt.Cells(son, hedefKolon).Value = degerD
                        Else
                            dt.Cells(son, hedefKolon).ClearContents
                        End If
                    Else
                        dt.Cells(son, hedefKolon).ClearContents
                    End If
                    
                    ' C sütunu = KKEG
                    If Not IsError(degerC) Then
                        If Trim(CStr(degerC)) <> "" Then
                            dt.Cells(son, hedefKolon + 1).Value = degerC
                        Else
                            dt.Cells(son, hedefKolon + 1).ClearContents
                        End If
                    Else
                        dt.Cells(son, hedefKolon + 1).ClearContents
                    End If
                    
                End If
                
                hedefKolon = hedefKolon + 2
                
            End If
            
        End If
        
    Next i
    
    MsgBox "Veriler Data sayfasına aktarıldı.", vbInformation

Cikis:
    On Error Resume Next
    hsp.Protect sifre
    dt.Protect sifre
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

HataYakala:
    MsgBox "Hata oluştu: " & Err.Description, vbCritical
    Resume Cikis

End Sub

 

[spacebar]

üstad kusursuz çalışıyor. tüm meslektaşlarımın kullanacağı bir çalışma olacak. ellerinize sağlık.