giderleştirme takibi

spacebar · Pazartesi saat 12:08'de

merhaba sayın üstadlarım.
gelecek aylara ait giderler ve gider takibi dosyam var. yapmak istediğim hesaplama sayfasında pivot tabloda bulunan değerleri data sayfasına aktarmak istiyorum. ancak makro kodlarım düzgün çalışmıyor. örneğin ocak 2027 ye veri atmıyor. makro kodlarının revize edilmesini veya yeniden yazılmasını istiyorum.
yardımlarınız için şimdiden teşekkür ederim. saygılarımla...

spacebar · Dün 11:57 da

bütün meslektaşlarımın kullanacağı bir çalışma olacak. yardım lütfen.

Ali · Dün 15:38 da

Eğer doğru anladıysam aşağıdaki makroyu dener misiniz.

Kod:

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 sonC As Long, sonD As Long
    
    sifre = "karzarar.org "
    
    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
    
    sonC = hsp.Cells(hsp.Rows.Count, "C").End(xlUp).Row
    sonD = hsp.Cells(hsp.Rows.Count, "D").End(xlUp).Row
    son2 = WorksheetFunction.Max(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
        MsgBox "Yıl aralık dışında. Sadece 2026 - 2033 arası destekleniyor.", vbCritical
        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
        
        degerD = hsp.Cells(i, "D").Value
        degerC = hsp.Cells(i, "C").Value
        
        ' D boşsa bu satırı tamamen geç
        If Not IsError(degerD) Then
            If Trim(CStr(degerD)) <> "" Then
                
                dt.Cells(son, hedefKolon).Value = degerD
                
                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
                
                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 · Dün 16:04 da

Ali' Alıntı:

Eğer doğru anladıysam aşağıdaki makroyu dener misiniz.

Kod:

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 sonC As Long, sonD As Long
  
    sifre = "karzarar.org "
  
    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
  
    sonC = hsp.Cells(hsp.Rows.Count, "C").End(xlUp).Row
    sonD = hsp.Cells(hsp.Rows.Count, "D").End(xlUp).Row
    son2 = WorksheetFunction.Max(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
        MsgBox "Yıl aralık dışında. Sadece 2026 - 2033 arası destekleniyor.", vbCritical
        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
      
        degerD = hsp.Cells(i, "D").Value
        degerC = hsp.Cells(i, "C").Value
      
        ' D boşsa bu satırı tamamen geç
        If Not IsError(degerD) Then
            If Trim(CStr(degerD)) <> "" Then
              
                dt.Cells(son, hedefKolon).Value = degerD
              
                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
              
                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

üstad ilginiz için teşekkür ederim. data sayfasında ilgili yerlere doğru atıyor. ancak pivot tablodaki genel toplam satırlarını atmaması gerekiyor. onuda düzeltirsek süper olacak. onun haricinde mükemmel çalışıyor.

Ali · Dün 17:38 da

Aşağıdaki kodlar ile değiştirin.

Kod:

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 sonC As Long, sonD As Long
    
    sifre = "karzarar.org "
    
    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
    
    sonC = hsp.Cells(hsp.Rows.Count, "C").End(xlUp).Row
    sonD = hsp.Cells(hsp.Rows.Count, "D").End(xlUp).Row
    son2 = WorksheetFunction.Max(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
        MsgBox "Yıl aralık dışında. Sadece 2026 - 2033 arası destekleniyor.", vbCritical
        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
        
        If i <> 26 Then
        
            degerD = hsp.Cells(i, "D").Value
            degerC = hsp.Cells(i, "C").Value
            
            If Not IsError(degerD) Then
                If Trim(CStr(degerD)) <> "" Then
                    
                    dt.Cells(son, hedefKolon).Value = degerD
                    
                    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
                    
                    hedefKolon = hedefKolon + 2
                    
                End If
            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 · Dün 17:46 da

üstad toplam satırını yine atıyor

Ali · Dün 17:54 da

5 nolu mesajı denedim atmadı bir daha kopyalayıp dener misiniz.

spacebar · Dün 18:14 da

üstad bir kaç defa denedim yine atıyor

giderleştirme takibi

spacebar

Ekli dosyalar

spacebar

Ali

Özel Üye

spacebar

Ali

Özel Üye

spacebar

Ali

Özel Üye

spacebar