ters bakiyeli hesap

[pliyades]

Bilanço mizanı için kod yazmak

Merhaba arkadaşlar.
ekteki dosyada belki çok basit ama tüm ugraşmalarıma ragmen yapamadığım bişey var.
data mizan çalışma sayfasındaki B5 hücresindeki hesap kodunu hesap karakteristigi çalışma sayfasında arasın bulsun ve karakteristigine baksın, eğer B ise hesabın karakteri ve data mizan çalışma sayfasındaki bakiyesi alacak bakiyesi ise (yani ters bakiyede ise) ters bakiye tutarını yazsın. yada A ise hesap karakteri yine data mizan sayfasındaki bakiyesi borç ise(yani ters bakiyede ise) bu ters bakiyeyi getirsin. bunların dısında hesap karakteri C ise herhangi bişey yapmasına gerek dikkate bile almasın.
Tabi bunları yaparken data mizan çalışma sayfasındaki masraf merkezlerine göre ayırsın (bu arada masraf merkezleri birer illeri ifade ediyor yani 1000=şirket merkezi, 1100=adana,1200=antep,1300=hatay,1400=mersin,1500=osmaniye,1600=kilis)
yani hangi ilde hangi hesaplarda ters bakiyeler var bunu listesi gerekiyor.
data aslında çok uzun tek düzen hesap planını bilenler varsa 100 den 990 kadar hesaplara ve bunların alt hesapları oldugunu bilir bu nedenle cok uzun yazdırıldıgında 70 sayfa tutuyor ve bunlara tek tek bakmak gözleri yoruyor.
şimdiden ilgilenen arkdaşlara teşekkür ediyorum.

 

[uzmanamele]

merhab
konu başlıklarınızı sorunuzla ilgili seçmeye dikkat ediniz.
lütfen konunun başlığını değiştiriniz.

 

[Zeki Gürsoy]

Sub tekduzen_plan2()
Dim i As Long, arr() As Variant, s As Long
Dim f As Object, x As Integer, w As Byte, j As Byte

On Error Resume Next

arr = Array(3, 5, 4, 10, 11)

    With Sheets("HESAP KARAKTERİSTİGİ")
    
        For i = 2 To [c50000].End(3).Row
            
            Set f = .Range("b1:b10000").Find( _
                CStr(Trim(Cells(i, "c"))), lookat:=xlWhole)
                
                If .Cells(f.Row, "d") = "B" Then
                    x = 11
                ElseIf .Cells(f.Row, "d") = "A" Then
                    x = 10
                Else
                    x = 0
                End If
                
            If x <> 0 Then
            
                If Cells(i, x) > 0 Then
                    With Sheets("" & Cells(i, "e"))
                        s = WorksheetFunction.CountA(.[b:b])
                        w = 1
                        For j = 0 To UBound(arr)
                            w = w + 1
                            .Cells(s + 1, w) = Cells(i, arr(j))
                        Next j
                    End With
                End If
                
            End If

        Next i
        
    End With
    
MsgBox "İşlem tamamlandı", vbInformation
End Sub

 

[pliyades]

merhaba

Zeki üstad yeni dosyayı ekledim boş zamanında bakarsan sevinirim.

 

[Zeki Gürsoy]

#3 nolu mesajımdaki eklenti yenilendi.

 

[pliyades]

Zeki üstad ellerine saglık allah ne muradın varsa versin çok teşekkür ediyorum.