dökümde düzenleme

[igultekin2000]

iyi günler;
yevmiye defterini daha kullanılır hale getirirken borç-alacak kısmını ayrı yazdırmak istiyordum. kullandığım kod şu şekildedir , teşekkürler

Sub yevmiye_duzenle()
   sonsatir = Cells(Rows.Count, "B").End(3).Row + 1
   Range("F5:M" & sonsatir).ClearContents
 
  satir = 4
For i = 4 To sonsatir
maddeno = Cells(i, "A").Value
tarihaciklama = Cells(i - 1, "B").Value
If Cells(i, "B").Value = "T O P L A M" Then Exit Sub


      If Left(maddeno, 1) = "-" Then
        madde = Replace(Replace(maddeno, " ", ""), "-", "")
        tarih = sayiayir(tarihaciklama)
        althesap = ""
        anakod = ""
        GoTo son
     End If
    
     If InStr(maddeno, " ") > 0 Then
        althesap = maddeno
        GoTo son
     End If
    
     If 0 + maddeno > 0 Then
        anakod = maddeno
        althesap = ""
     End If
    
son:
     If althesap <> "" And maddeno = "" Then
        satir = satir + 1
        aciklama = Cells(i, "B").Value
        borc = Cells(i, "C").Value
        alacak = Cells(i, "E").Value
        
        Cells(satir, "F").Value = madde
        Cells(satir, "G").Value = tarih
        Cells(satir, "H").Value = anakod
        Cells(satir, "I").Value = althesap
        Cells(satir, "J").Value = tarihaciklama
        Cells(satir, "K").Value = aciklama
        Cells(satir, "L").Value = borc
        Cells(satir, "M").Value = alacak
        borc = ""
        alacak = ""
        aciklama = ""
        tarihaciklama = ""
     End If
   Next i
End Sub

Function sayiayir(sadecesayistr)
  liste = "0123456789."
  For k = 1 To Len(sadecesayistr)
    harf = Mid(sadecesayistr, k, 1)
    If InStr(liste, harf) > 0 Then
       sayi = sayi & harf
    End If
  Next k
  sayiayir = sayi
End Function

 

[Korhan Ayhan]

Deneyiniz.

"G" sütununa gelmesi gereken veriyi anlamadığım için boş bıraktım.

Option Explicit

Sub Yevmiye_Defteri_Duzenle()
    Dim Son As Long, Veri As Variant, X As Long, Y As Long, Say As Long
    Dim Madde_No As String, Ana_Hesap_Kodu As String, Tip As String, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Range("F5:M" & Rows.Count).ClearContents
    
    Son = Cells(Rows.Count, 4).End(3).Row
    If Son = 5 Then Son = 6
    
    Veri = Range("A5:E" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 8)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            If InStr(1, Veri(X, 1), "-") > 0 Then
                Madde_No = Replace(Replace(Veri(X, 1), " ", ""), "-", "")
            End If
                
            If InStr(1, Veri(X, 1), " ") > 0 And InStr(1, Veri(X, 1), "-") = 0 Then
                Ana_Hesap_Kodu = Veri(X - 1, 1)
                If Veri(X - 1, 4) <> "" Then
                    Tip = "B"
                Else
                    Tip = "A"
                End If
            
                For Y = X To UBound(Veri)
                    If Veri(Y, 1) <> "" Then
                        If Veri(Y + 1, 1) <> "" Then Exit For
                        Say = Say + 1
                        Liste(Say, 1) = Madde_No
                        Liste(Say, 2) = ""
                        Liste(Say, 3) = Ana_Hesap_Kodu
                        Liste(Say, 4) = Veri(Y, 1)
                        Liste(Say, 5) = Veri(Y, 2)
                        Liste(Say, 6) = Veri(Y + 1, 2)
                        If Tip = "B" Then
                            Liste(Say, 7) = Veri(Y + 1, 3)
                        Else
                            Liste(Say, 8) = Veri(Y + 1, 3)
                        End If
                    End If
                Next
                X = Y
            End If
        End If
    Next

    If Say > 0 Then
        Range("F5").Resize(Say, 8) = Liste
        Range("F:M").Columns.AutoFit
    End If

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[igultekin2000]

Deneyiniz.

"G" sütununa gelmesi gereken veriyi anlamadığım için boş bıraktım.

Teşekkür ederim, sorunsuz çalışıyor, iyi çalışmalar