- Katılım
- 12 Eylül 2004
- Mesajlar
- 871
- Excel Vers. ve Dili
-
Excel 2019 Türkçe (Ev)
Excel 2013 Türkçe (Okul)
Aşağıdaki kod ile klasör altında txt dosyasyı oluşturuyor. Ancak çalışma zaman hatası veriyor.
Kod:
Sub DOSYA_OLUSTUR()
Dim dosyaAdi As String
Dim fNumber As Integer
Dim fName As String
Dim outputDir As String
Dim donguSatir As Long
Dim yazilanSatir As Integer
Dim kisiSayisi As Long
Dim toplamTutar As Double
Dim header As String * 144, detay As String * 241, trailer As String * 28
header = Space(89)
outputDir = InputBox("Dosyanın oluşacağı Folder Giriniz ")
If (Len(outputDir) = 0) Then
Exit Sub
End If
If Dir(outputDir, vbDirectory) = vbNullString Then
MkDir outputDir
End If
Sheets("DATA").Select
If Cells(4, 5) < Cells(2, 8) - 1 Then MsgBox "Ödeme Tarihi Gün tarihinden küçük olamaz !!", vbCritical: Exit Sub
If (Cells(2, 5) = vbEmpty Or Trim(Cells(2, 7)) = "" Or Cells(3, 5) = vbEmpty Or Cells(4, 5) = vbEmpty Or Cells(4, 7) = vbEmpty Or Cells(5, 5) = vbEmpty) Then
MsgBox "Kurum tarafından doldurulması gekeren zorunlu alanlarda eksiklik bulunmakta", vbCritical
Exit Sub
Else
If (Not IlkKontrol) Then
fNumber = FreeFile()
CISM = Format(Cells(2, 5), "00000000000") & Format(Cells(2, 7), "000")
fName = InputBox("Dosya Adını Giriniz. (" & outputDir & " altında oluşacaktır) ", Dosya, dnm & CISM)
If (Len(fName) = 0) Then
Exit Sub
End If
fName = outputDir & "\" & fName & ".Txt"
If Dir(fName) <> vbNullString Then
MsgBox fName & " isimli daha önceden kaydedildiği için, lütfen başka bir dosya ismi ile kayıt yapınız", vbCritical
Exit Sub
End If
fNumber = FreeFile
Open fName For Output As fNumber
hLine.SabitKod = "H"
hLine.Kurummus = Format(Cells(2, 5), "00000000000")
hLine.ODMTAHNDN = Format(Cells(2, 7), "000")
hLine.BordroNumarasi = Format(Now(), "yyMMddHHmm")
hLine.BordroTarihi = Format(Now, "yyyyMMdd")
hLine.OdemeTarihi = Format(Cells(4, 5), "yyyyMMdd")
hLine.OdemeKodu = Cells(4, 7)
hLine.Aciklama = Cells(5, 5)
hLine.SatırSonu = vbCrLf
Print #fNumber, hLine.SabitKod & hLine.Kurummus & hLine.ODMTAHNDN & hLine.BordroNumarasi & hLine.BordroTarihi & hLine.OdemeTarihi & hLine.OdemeKodu & hLine.Aciklama
For donguSatir = 14 To 65536
If Trim(Cells(donguSatir, 4)) = "" Then GoTo CIKIS
If (Cells(donguSatir, 4) <> "" And Trim(Cells(donguSatir, 5)) <> "" And Cells(donguSatir, 6) <> vbEmpty) Then
dLine.TUR = "DH"
dLine.SUBE = Mid(Cells(donguSatir, 4), 11, 4)
dLine.HESAP = "000" & Mid(Cells(donguSatir, 4), 15, 8)
dLine.EKNO = Mid(Cells(donguSatir, 4), 23, 4)
dLine.TUTAR = Replace(Format(Cells(donguSatir, 5), "000000000000000.00"), ".", ",")
dLine.ADI = Cells(donguSatir, 6)
dLine.SOYADI = Cells(donguSatir, 7)
dLine.Aciklama = Cells(donguSatir, 8)
dLine.SatırSonu = vbCrLf
Print #fNumber, dLine.TUR & dLine.SUBE & dLine.HESAP & dLine.EKNO & dLine.TUTAR & dLine.ADI & dLine.SOYADI & dLine.Aciklama
kisiSayisi = 1 + kisiSayisi
toplamTutar = toplamTutar + Cells(donguSatir, 5)
End If
Next
CIKIS:
tLine.kisiSayisi = Format(kisiSayisi, "0000000")
tLine.Miktar = Replace(Format(toplamTutar, "000000000000000.00"), ".", ",")
tLine.SabitKod = "T"
tLine.SatırSonu = vbCrLf
Print #fNumber, tLine.SabitKod & tLine.kisiSayisi & tLine.Miktar
Close #fNumber
MsgBox "Dosya " & fName & " olarak oluşturuldu", vbInformation
End If
End If
End Sub