title image


Smiley Re: DTA-Dateien mit MS Excel erstellen - wer weiss Rat
Hallo Jens,



hier mein Makro - die Zellbezüge musst du natürlich auf deine Gegebenheiten anpassen!



Type AustauschTyp

Feld As String * 128

End Type





Sub austausch()

Dim EuroDa As String



If Worksheets("Vorspann DTA").Cells(11, 4) = True Then

EuroDa = "(Beträge werden als Euro überwiesen !)"

Else

EuroDa = "(Beträge werden als DM überwiesen !)"

End If

oben:



datenlw = UCase(Left(Worksheets("Vorspann DTA").Cells(19, 2), 1))

If datenlw "A" And datenlw "B" Then

MsgBox ("Falsche Laufwerksbezeichnung!" & Chr(13) & Chr(13) & "Zulässig ist nur A oder B !")

Worksheets("Vorspann DTA").Activate

Cells(19, 2).Activate

Exit Sub

End If



weitergehts = MsgBox(EuroDa & Chr(13) & Chr(13) & "DTA-Datei DTAUS1 wird erzeugt." & Chr(13) & _

"Bitte formatierte Diskette in Laufwerk " & datenlw & " einlegen" & Chr(13) & _

"und Drucker einschalten!" & Chr(13) & Chr(13) & "Fertig ?", vbOKCancel)

If weitergehts = vbCancel Then Exit Sub



On Error GoTo Fehlerbehandlung:



datei = datenlw & ":\*.*"

Kill datei



On Error GoTo 0





If weitergehts = vbNein Then Exit Sub

Dim aktuell As String * 128

Dim aktuell2 As String * 128

Dim nameSp, BeitragSp, SollSp, GutSp, BLZSp, KontoSp, ZweckSp, GutOderLast As Integer

Dim AktuellerSatz As AustauschTyp



nameSp = CInt(Worksheets("Vorspann DTA").Cells(12, 2))

SollSp = CInt(Worksheets("Vorspann DTA").Cells(13, 2))

GutSp = CInt(Worksheets("Vorspann DTA").Cells(14, 2))

ZweckSp = CInt(Worksheets("Vorspann DTA").Cells(15, 2))

BLZSp = CInt(Worksheets("Vorspann DTA").Cells(16, 2))

KontoSp = CInt(Worksheets("Vorspann DTA").Cells(17, 2))

GutOderLast = CInt(Worksheets("Vorspann DTA").Cells(11, 3))





If nameSp = 0 Or (SollSp = 0 And GutOderLast = 1) Or (GutSp = 0 And GutOderLast = 2) Or BLZSp = 0 Or KontoSp = 0 Then

MsgBox "Ein Eintrag in Zeile 12 bis 17 ist fehlerhaft oder fehlt!"

Worksheets("Vorspann DTA").Activate

Cells(12, 2).Activate

Exit Sub

End If





If Worksheets("Vorspann DTA").Cells(11, 3) 1 And Worksheets("Vorspann DTA").Cells(11, 3) 2 Then

MsgBox "Keine Angabe zu Lastschrift bzw. Gutschrift in Zeile 11!"

Worksheets("Vorspann DTA").Select

Cells(11, 1).Select

Exit Sub

End If

ChDrive Workbooks(ActiveWorkbook.Name).Path

ChDir Workbooks(ActiveWorkbook.Name).Path



Close #1

Open "dtaus1" For Append As 1

Close #1

Kill "dtaus1"

Open "dtaus1" For Random As #1 Len = Len(AktuellerSatz)

aktuell = String(128, " ")

If Worksheets("Vorspann DTA").Cells(11, 3) = 1 Then

Mid(aktuell, 1, 7) = "0128ALK"

BeitragSp = SollSp

Else

Mid(aktuell, 1, 7) = "0128AGK"

BeitragSp = GutSp

End If

If nameSp = 0 Or BeitragSp = 0 Or nameSp = 0 Or BLZSp = 0 Or KontoSp = 0 Then

MsgBox "Ein Eintrag in Zeile 12 bis 17 ist fehlerhaft oder fehlt!"

Worksheets("Vorspann DTA").Select

Cells(13, 2).Select



Exit Sub

End If



zahl = Worksheets("Vorspann DTA").Cells(3, 2)

Call NullenAuffüllen(zahl, 8)

Mid(aktuell, 8, 8) = zahl

BLZ = zahl



Mid(aktuell, 16, 8) = "00000000"



Absender = ""

Absender2 = UCase(Left(Worksheets("Vorspann DTA").Cells(5, 2), 27))

For k = 1 To Len(Absender2)

buchst = Mid(Absender2, k, 1)

If buchst = "Ä" Then buchst = Chr(142)

If buchst = "Ü" Then buchst = Chr(154)

If buchst = "Ö" Then buchst = Chr(153)

If buchst = "ß" Then buchst = Chr(225)

If buchst = "(" Or buchst = ")" Then buchst = "/"

Absender = Absender & buchst

Next

Mid(aktuell, 24, 27) = Absender







If Not IsDate(Worksheets("Vorspann DTA").Cells(6, 2)) Then

Close #1

Exit Sub

End If



Datum1 = Day(Worksheets("Vorspann DTA").Cells(6, 2))

Datum1 = CStr(Datum1)

Call NullenAuffüllen(Datum1, 2)

Datum2 = Month(Worksheets("Vorspann DTA").Cells(6, 2))

Datum2 = CStr(Datum2)

Call NullenAuffüllen(Datum2, 2)

Datum3 = Year(Worksheets("Vorspann DTA").Cells(6, 2))

Datum3 = Right(CStr(Datum3), 2)

DatumA = Datum1 & Datum2 & Datum3

Mid(aktuell, 51, 6) = DatumA



zahl = Worksheets("Vorspann DTA").Cells(4, 2)

Call NullenAuffüllen(zahl, 10)

Mid(aktuell, 61, 10) = zahl

KontoNr = zahl



Mid(aktuell, 71, 10) = "0000000000"



If Worksheets("Vorspann DTA").Cells(11, 4) = True Then

Mid(aktuell, 128, 1) = "1" 'Euro als Währung

End If



AktuellerSatz.Feld = aktuell

Put #1, 1, AktuellerSatz



Dim SummeZahl, SummeBLZ, SummeKonto, SummeBetrag As Double

k = 2

dsatchrr = 1

While Worksheets("Daten").Cells(k, nameSp) ""

If IsNumeric(Worksheets("daten").Cells(k, BeitragSp)) And Worksheets("daten").Cells(k, BLZSp) "" And Worksheets("daten").Cells(k, KontoSp) "" Then

If Worksheets("daten").Cells(k, BeitragSp) > 0 Then

dsatchrr = dsatchrr + 1

aktuell = String(128, " ")

aktuell2 = String(128, " ")

Mid(aktuell, 1, 5) = "0187C"



Mid(aktuell, 6, 8) = BLZ



zahl = Worksheets("Daten").Cells(k, BLZSp)

SummeZahl = SummeZahl + 1

SummeBLZ = SummeBLZ + CDbl(zahl)

Call NullenAuffüllen(zahl, 8)

Mid(aktuell, 14, 8) = zahl



zahl = Worksheets("Daten").Cells(k, KontoSp)

SummeKonto = SummeKonto + CDbl(zahl)

Call NullenAuffüllen(zahl, 10)

Mid(aktuell, 22, 10) = zahl

If Worksheets("Vorspann DTA").Cells(11, 3) = 1 Then

Mid(aktuell, 32, 18) = "000000000000005000"

Else

Mid(aktuell, 32, 18) = "000000000000051000"

End If

zahl = Worksheets("Daten").Cells(k, BeitragSp) * 100

SummeBetrag = SummeBetrag + CDbl(zahl)

Call NullenAuffüllen(zahl, 11)



If Worksheets("Vorspann DTA").Cells(11, 4) = True Then

Mid(aktuell, 51, 11) = "00000000000" 'Euro

Mid(aktuell, 80, 11) = zahl 'Euro

Else

Mid(aktuell, 51, 11) = zahl 'DM

Mid(aktuell, 80, 11) = "00000000000" 'DM

End If



Mid(aktuell, 62, 8) = BLZ



Mid(aktuell, 70, 10) = KontoNr





Mitglied = ""

Mitglied2 = UCase(Left(Worksheets("Daten").Cells(k, nameSp), 27))

For t = 1 To Len(Mitglied2)

buchst = Mid(Mitglied2, t, 1)

If buchst = "Ä" Then buchst = Chr(142)

If buchst = "Ü" Then buchst = Chr(154)

If buchst = "Ö" Then buchst = Chr(153)

If buchst = "ß" Then buchst = Chr(225)

If buchst = "(" Or buchst = ")" Then buchst = "/"

Mitglied = Mitglied & buchst

Next

Mid(aktuell, 94, 27) = Mitglied



Mid(aktuell2, 1, 27) = Absender



Zweck = ""

Zweck2 = UCase(Left(Worksheets("Daten").Cells(k, ZweckSp), 27))

For t = 1 To Len(Zweck2)

buchst = Mid(Zweck2, t, 1)

If buchst = "Ä" Then buchst = Chr(142)

If buchst = "Ü" Then buchst = Chr(154)

If buchst = "Ö" Then buchst = Chr(153)

If buchst = "ß" Then buchst = Chr(225)

If buchst = "(" Or buchst = ")" Then buchst = "/"

Zweck = Zweck & buchst

Next



Mid(aktuell2, 28, 27) = Zweck



If Worksheets("Vorspann DTA").Cells(11, 4) = True Then

Mid(aktuell2, 55, 1) = "1" 'Euro als Währung

End If



Mid(aktuell2, 58, 2) = "00"



AktuellerSatz.Feld = aktuell

Put #1, dsatchrr, AktuellerSatz

dsatchrr = dsatchrr + 1

AktuellerSatz.Feld = aktuell2

Put #1, dsatchrr, AktuellerSatz

End If

End If

k = k + 1

Wend

aktuell = String(128, " ")

Mid(aktuell, 1, 5) = "0128E"



zahl = CStr(SummeZahl)

Call NullenAuffüllen(zahl, 7)

Mid(aktuell, 11, 7) = zahl





zahl = CStr(SummeBetrag)

Call NullenAuffüllen(zahl, 13)

If Worksheets("Vorspann DTA").Cells(11, 4) = True Then

Mid(aktuell, 18, 13) = "0000000000000"

Mid(aktuell, 65, 13) = zahl

Else

Mid(aktuell, 18, 13) = zahl

Mid(aktuell, 65, 13) = "0000000000000"

End If



zahl = CStr(SummeKonto)

Call NullenAuffüllen(zahl, 17)

Mid(aktuell, 31, 17) = zahl



zahl = CStr(SummeBLZ)

Call NullenAuffüllen(zahl, 17)

Mid(aktuell, 48, 17) = zahl



dsatchrr = dsatchrr + 1

AktuellerSatz.Feld = aktuell

Put #1, dsatchrr, AktuellerSatz



Close #1

Worksheets("begleitzettel").Cells(12, 2) = SummeZahl

Worksheets("begleitzettel").Cells(14, 2) = SummeBetrag / 100

Worksheets("begleitzettel").Cells(15, 2) = SummeKonto

Worksheets("begleitzettel").Cells(16, 2) = SummeBLZ



Call DTA_Blatt_Drucken

zählerfehler = 0

On Error GoTo fehlerbehandlung2:



datei = datenlw & ":\dtaus1"

FileCopy "dtaus1", datei

MsgBox "DTA - Datei ist erstellt und auf Diskette kopiert worden!"

Worksheets("Hauptmenü").Activate

Exit Sub



Fehlerbehandlung:

If Err 53 And Err 71 And Err 75 And Err 70 Then MsgBox "Fehler: " & Err & " " & Error(Err) & " - Bitte Fehlerursache beseitigen!": Resume oben



If Err = 71 Then MsgBox "Fehler: " & Err & " " & Error(Err) & "; Diskette einlegen!": Resume oben

If Err = 75 Or Err = 70 Then MsgBox "Fehler: " & Err & " " & Error(Err) & "; Schreibschutz entfernen!": Resume oben

If Err = 53 Then Resume Next

Return



fehlerbehandlung2:

zählerfehler = zählerfehler + 1

If zählerfehler > 3 Then MsgBox "Fehler wurde nicht behoben - Vorgang wird abgebrochen - Bitte mit neuer Diskette wiederholen!": Exit Sub

If Err 71 And Err 61 And Err 75 And Err 70 Then MsgBox "Fehler: " & Err & " " & Error(Err) & " - Bitte Fehlerursache beseitigen!"

If Err = 71 Then MsgBox "Fehler: " & Err & " " & Error(Err) & "; Diskette einlegen!"

If Err = 61 Then MsgBox "Fehler: " & Err & " " & Error(Err) & "; Diskette hat Unterverzeichnisse! Andere Diskette verwenden oder zum Explorer wechseln und Verrzeichnis löschen!"

If Err = 75 Or Err = 70 Then MsgBox "Fehler: " & Err & " " & Error(Err) & "; Schreibschutz entfernen!"

Resume



Return



End Sub





Sub NullenAuffüllen(UrZahl, NullenZahl)

vielenullen = String(20, "0")

UrZahl = vielenullen & UrZahl

UrZahl = Right(UrZahl, NullenZahl)

End Sub



Sub DTA_Blatt_Drucken()

On Error GoTo Fehlerbehandlung

Worksheets("Begleitzettel").Activate

ActiveWindow.SelectedSheets.PrintOut copies:=1

Exit Sub



Fehlerbehandlung:

MsgBox "Fehler beim Drucken: " & Error(Err)

End Sub
(Falls vorhanden:) Tabellen sind eingefügt mit Tool von Schorsch Dabbeljuh
hier sein offizieller Download-Link

(Fast) alles über Excel-Formeln ohne VBA findet man auf der Seite Excelformeln

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: