Zirve muhasebeci paketinden Netle e-defter uygulamasına dönüşüm yapmak için aşağıdaki excel macro kod yardımcınız olabilir.
İlgili paketten ilgili döneme ilişkin "fiş listesi" excel ortamına aktarılır. excel dosyası açılır ve ikinci sheet olarak "netle" adında bir boş sayfa eklenir.
macro kodlarına aşağıdaki kod eklenir ve excel macro calistir yardımı ile "Netle-Defter" formatlarına uygun çıktı alınabilir.
NotBuradaki kodlar örnek veri modeli için hazırlanmıştır. Her veride kesin ve tutarlı sonuçlar vermesi beklenmemektedir. transfer aşamasında yardımcı olması adına tasarlanmıştır.
Sub NetleOlarakDuzenle() 'tum fisleri gez ve netle ortamına aktar Dim newIndex As Integer Dim lastFisNo As String Dim lastFisTar As String Dim lastEntryComment As String Dim borc As Double Dim alacak As Double Dim itemDesc As String Dim ht Dim dt Set ht = CreateObject("System.Collections.Hashtable") Set dt = CreateObject("System.Collections.Hashtable") ' j=1 : odeme turleri fis bazında belirleniyor... ' j=2 : belirlenen odeme turleri yerine yazılıyor For J = 1 To 2 newIndex = 2 For I = 1 To 7000 If (Sheet1.Cells(I, 11) = "Fiş Tarihi :") Then lastFisTar = Sheet1.Cells(I, 12) & Sheet1.Cells(I, 13) lastEntryComment = Sheet1.Cells(I - 2, 4) & Sheet1.Cells(I - 2, 5) & Sheet1.Cells(I - 2, 6) & Sheet1.Cells(I - 2, 7) If (lastEntryComment = "") Then lastEntryComment = Sheet1.Cells(I - 1, 4) & Sheet1.Cells(I - 1, 5) & Sheet1.Cells(I - 1, 6) & Sheet1.Cells(I - 1, 7) End If End If If (Sheet1.Cells(I, 11) = "Fiş No :") Then lastFisNo = Right("00000000" & Sheet1.Cells(I, 12) & Sheet1.Cells(I, 13), 8) End If heskod = Sheet1.Cells(I, 2) testPos = InStr(1, heskod, "-") If (heskod > "" And testPos > 0) Then If (J = 1) Then If (Left(heskod, 3) = "100") Then If (CStr(ht(lastFisNo)) = "") Then ht(lastFisNo) = "Nakit" Else ht(lastFisNo) = "" 'daha onceden bulunan degeri sıfırla, aynı anda iki odeme turu olamaz End If End If If (Left(heskod, 3) = "102") Then If (CStr(ht(lastFisNo)) = "") Then ht(lastFisNo) = "Banka" Else ht(lastFisNo) = "" 'daha onceden bulunan degeri sıfırla, aynı anda iki odeme turu olamaz End If End If If (Left(heskod, 3) = "309") Then If (CStr(ht(lastFisNo)) = "") Then ht(lastFisNo) = "KrediKarti" Else ht(lastFisNo) = "" 'daha onceden bulunan degeri sıfırla, aynı anda iki odeme turu olamaz End If End If End If borc = Sheet1.Cells(I, 11) alacak = Sheet1.Cells(I, 12) + Sheet1.Cells(I, 13) + Sheet1.Cells(I, 14) itemDesc = Sheet1.Cells(I, 7) & Sheet1.Cells(I, 8) Dim abc() As String abc = Split(itemDesc, "-") ub = UBound(abc) 'detail comment hazırlanıyor If (ub > 3) Then dts = "" For uindex = 3 To ub dts = dts & " " & abc(uindex) Next Sheet2.Cells(newIndex, 16) = dts End If If (ub = 3) Then Sheet2.Cells(newIndex, 16) = abc(3) End If If (ub = 2) Then Sheet2.Cells(newIndex, 16) = abc(2) End If 'dokuman turu anlasiliyor If (J = 1 And itemDesc > "") Then sourceDT = abc(0) aktifdt = CStr(dt(lastFisNo)) currDt = "" If (sourceDT = "Fatura") Then currDt = "Invoice" End If If (sourceDT = "Banka Ekstresi") Then currDt = "Other" End If If (sourceDT = "Makbuz") Then currDt = "Receipt" End If If (sourceDT = "Uc.Bord.") Then currDt = "Other" End If If (currDt > "") Then If (currDt = "Other" Or currDt = "Invoice" Or currDt = "Check") Then If (ub > 3) Then Sheet2.Cells(newIndex, 14) = "'" & abc(2) Sheet2.Cells(newIndex, 15) = CDate(abc(1)) End If If (ub = 3) Then 'doctype+tar+no Sheet2.Cells(newIndex, 14) = "'" & abc(2) Sheet2.Cells(newIndex, 15) = CDate(abc(1)) End If If (ub = 2) Then 'doctype+no If (InStr(1, abc(1), ".") > 0) Then Sheet2.Cells(newIndex, 15) = CDate(abc(1)) Else Sheet2.Cells(newIndex, 14) = "'" & abc(1) End If End If 'dokuman tarihi halen boş ise, yevmiye tarihi ile aynı giriş yap If (Sheet2.Cells(newIndex, 15) = "") Then Sheet2.Cells(newIndex, 15) = CDate(lastFisTar) End If End If If (aktifdt = "") Then dt(lastFisNo) = currDt Else If (aktifdt <> currDt) Then Err.Raise vbObjectError + WidthErrorNumber, "", "aynı fis icinde iki tur dokuman var - " & lastFisNo End If End If End If End If Sheet2.Cells(newIndex, 1) = "Murat Yetkin" Sheet2.Cells(newIndex, 2) = CDate(lastFisTar) Sheet2.Cells(newIndex, 3) = CDate(lastFisTar) Sheet2.Cells(newIndex, 4) = "Mahsup" Sheet2.Cells(newIndex, 5) = "'" & lastFisNo Sheet2.Cells(newIndex, 6) = lastEntryComment Sheet2.Cells(newIndex, 7) = heskod Sheet2.Cells(newIndex, 8) = "TRL" Sheet2.Cells(newIndex, 9) = borc + alacak If (borc > 0) Then Sheet2.Cells(newIndex, 10) = "D" Else Sheet2.Cells(newIndex, 10) = "C" End If If (J = 2) Then odemeTuru = CStr(ht(lastFisNo)) If (odemeTuru > "" And lastEntryComment <> "Açılış Fişi") Then Sheet2.Cells(newIndex, 11) = "'" & odemeTuru End If dstr = CStr(dt(lastFisNo)) If (dstr > "") Then Sheet2.Cells(newIndex, 12) = dstr End If If dstr = "Other" Then Sheet2.Cells(newIndex, 13) = abc(0) End If End If Sheet2.Cells(newIndex, 17) = "'" & Sheet1.Cells(I, 4) newIndex = newIndex + 1 End If Next Next End Sub