Liste düzenleme

[igultekin2000]

İyi günler; muavin döküm alarak üzerinde düzenleme yapıyorum. kullandığım 600 satış ve 391 KDV hesap kodları.
Sayfa1’de C sütununu J sütununa alarak metne çevir ile tarih ve S.ile başlayan fatura numaralarını ayırıyorum.
Sayfa ikiye tarih ve fatura numaraları alıyorum.
Sayfa ikiye bana gerekli 600 ve 391 kodları ekliyorum.
Sonrasında Çoketopla formülü ile Sayfa1 Deki tutarları düzenli liste haline getiriyorum.
Bir kaç makroyu birleştirip biraz pratik hale getirmiştim, bilgisayar çökünce düzen bozuldu.

 

[YUSUF44]

Aşağıdaki makroyu dener misiniz? (Öncesinde sayfa1'deki başlıklarınızı kod içindeki gibi düzeltin lütfen, hücre içinde Alt+Enter kullanılmamış olsun)

Sub muhasebe()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
s2.Cells.ClearContents

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select distinct TARİH, mid([A Ç I K L A M A],12,18) as [FATURA NO] from [Sayfa1$] where tarih is not null"
Set rs = con.Execute(sorgu)
s2.[A2].CopyFromRecordset rs

sorgu = "select distinct left([HESAP KOD],9) as kod from [Sayfa1$] where left([HESAP KOD],3)='391' or left([HESAP KOD],3)='600'"
Set rs = con.Execute(sorgu)

s2.[C1].CopyFromRecordset rs
sonC = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "C").End(3).Row)
s2.Range("C2:C" & sonC).Copy: s2.[D1].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
s2.Range("C2:C" & sonC).ClearContents

sonfatura = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
sonhesap = WorksheetFunction.Max(2, s2.Cells(1, Columns.Count).End(xlToLeft).Column)
For fatura = 2 To sonfatura
    For hesap = 3 To sonhesap
        sorgu = "select sum([ALACAK (TL)]) from [Sayfa1$] where TARİH='" & s2.Cells(fatura, "A") & _
                "' and mid([A Ç I K L A M A],12,18)='" & s2.Cells(fatura, "B") & "'" _
                & " and left([HESAP KOD],9)='" & s2.Cells(1, hesap) & "'"
        Set rs = con.Execute(sorgu)
        s2.Cells(fatura, hesap).CopyFromRecordset rs
    Next
Next
End Sub

 

[igultekin2000]

Teşekkür ederim, işlem pratiğe dökülmüş oldu. Bir yerde hata mesajı verdi, kodun başına on error resume next koyunca işlemi tamamladı.

 

[YUSUF44]

O kodu kullanmayın bence. Çünkü hatayı gidermez, sadece gizler ve aslında istenen sonucun elde edilmesine de engel olabilir. Hata verdiği anda dosyanın durumunu inceleyip niye hata verdiğini anlamak ve o hatayı düzeltecek şekilde kodu düzenlemek gerekir.