Hallo Herrmann
Wusste gar nicht, dass ich so vermisst wurde. War mit Ostereier färben zu stark beschäftigt.
zu 1)
Anstellen von
Wert = Wert & Format(Arr08(A), "000000") '8) Stunde
nimm das hier
LTMP = 6
Lng = Len(Arr08(A))
Leer = WF.Rept("0", LTMP - Lng)
Wert = Wert & Leer & Arr08(A) '8) Stunde
Ich hab es nur bei Case 21, 27 eingebaut. Für die anderen Fälle ggf. analog ändern
zu 2)
Leg ein Blatt "Data" an. Das kannst du auch ausblenden
Dort lege ich am Programmende in A1 die letzte Laufnummer ab und lese Sie beim Start erst wieder zurück.
Der komplette Code dazu
Sub TT()
Dim Pfad As String, Datei As String, Z1 As Integer, LR As Long
Dim Wert As String, i As Long, j As Integer, Nr As Long
Dim Sp1 As Integer, Anz As Integer, WF, Lng As Integer, Leer As String
Dim Arr08, Arr14, Arr16, A As Integer, TMP As String, LTMP As Integer
Dim GrDat As Date, SpNix As Integer, LC As Integer
Dim LastNr As Range
'*** Vorgaben
Pfad = "C:\Users\Herrmann\Desktop\" 'mit \ am Ende
'Pfad = "E:\Excel\Temp\" 'mit \ am Ende
Datei = "Ausgabe.txt"
Z1 = 6 'beginne ab Zeile
Sp1 = 15 'Start ab Spalte O
SpNix = 24 ' XYZ auslassen
Set LastNr = Sheets("Data").Range("A1") 'Merken der letzten Laufenden Nr
'*** Ende Vorgaben
Set WF = WorksheetFunction
LR = Cells(Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
LC = Cells.SpecialCells(xlCellTypeLastCell).Column 'Letzte Spalte des gesamten Blattes
GrDat = DateSerial(Year(Date), Month(Date) - 1, 1) 'Grenzdatum = 01. des Vormonats
Nr = LastNr.Value
Close #1
Open Pfad & Datei For Output As 1
For i = Z1 To LR
For j = Sp1 To LC - 2 Step 3 'von Spalte O bis Ende
If Cells(i, j) "" And j SpNix Then 'nur, wenn nicht leer und nicht XYZ
'Grenzdatum prüfen
If Cells(i, 2) >= GrDat Then
'Mehrere Zeilen in einer Zelle?
Arr08 = Split(Cells(i, j + 1), vbLf) 'AF Typ
Arr14 = Split(Cells(i, j), vbLf) 'Std
Arr16 = Split(Cells(i, j + 2), vbLf) 'Kommentar
For A = 0 To UBound(Arr08) 'Wiederholung wenn mehrere Zeilen in Zelle
Select Case j
Case 15, 18 'bei Aufgabe 1 und 2
Wert = "RR" '1) fix
Wert = Wert & "N" '2) fix
Wert = Wert & "ST" '3) fix
Wert = Wert & Format(Nr + 1, "00000000") '4) laufende Nummer
LTMP = 10
TMP = Left(Range("D2"), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng)
Wert = Wert & TMP & Leer '5) Personalnummer plus Leerzeichen Max 10
Wert = Wert & Format(Cells(i, 2), "DDMMYYYY") '6) Datum (7 entfällt)
Wert = Wert & Format(Arr08(A), "000000") '8) Stunde
Wert = Wert & "H " '9) fix plus Leerzeichen
'--- '(10, 11, 12 entfällt)
LTMP = 6
TMP = Left(Cells(Z1 - 1, j), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng)
Wert = Wert & TMP & Leer '13) Aufgabe +Leerzeichen Max 6 Zeichen
'--- '(14, 15 entfällt)
LTMP = 39
TMP = Left(Arr16(A), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng) & "*"
Wert = Wert & TMP & Leer '16) Kommentar immer 39
Wert = Wert & WF.Rept(" ", 13) & "*" '17) fix zusätzliches * immer 14 Zeichen
Case 21, 27 'bei Aufgabe 3 und 5
Wert = "LE" '1) fix
Wert = Wert & "N" '2) fix
Wert = Wert & "ST" '3) fix
Wert = Wert & Format(Nr + 1, "00000000") '4) laufende Nummer
LTMP = 10
TMP = Left(Range("D2"), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng)
Wert = Wert & TMP & Leer '5) Personalnummer plus Leerzeichen Max 10
Wert = Wert & Format(Cells(i, 2), "DDMMYYYY") '6) Datum
Wert = Wert & Format(Cells(i, 2), "DDMMYYYY") '7) Datum2
LTMP = 6
Lng = Len(Arr08(A))
Leer = WF.Rept("0", LTMP - Lng)
Wert = Wert & Leer & Arr08(A) '8) Stunde
Wert = Wert & "H " '9) fix plus Leerzeichen
'--- '(10, 11 entfällt)
Wert = Wert & "L72 " '12) fix plus Leerzeichen
LTMP = 10
TMP = Left(Cells(Z1 - 1, j), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng)
Wert = Wert & TMP & Leer '13) Aufgabe +Leerzeichen Max 10 Zeichen
Wert = Wert & Format(Arr14(A), "000000000000") '14) Aufgabentyp 12 stellig
'--- '(15 entfällt)
LTMP = 23
TMP = Left(Arr16(A), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng) & "*"
Wert = Wert & TMP & Leer '16) Kommentar immer 23 +*
Case Is > 27 'ab Aufgabe 6
Select Case IsNumeric(Cells(Z1 - 1, j))
Case True 'Nur Ziffern
Wert = "RN" '1) fix
Wert = Wert & "N" '2) fix
Wert = Wert & "ST" '3) fix
Wert = Wert & Format(Nr + 1, "00000000") '4) laufende Nummer
LTMP = 10
TMP = Left(Range("D2"), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng)
Wert = Wert & TMP & Leer '5) Personalnummer plus Leerzeichen Max 10
Wert = Wert & Format(Cells(i, 2), "DDMMYYYY") '6) Datum
Wert = Wert & Format(Cells(i, 2), "DDMMYYYY") '7) Datum2
Wert = Wert & Format(Arr08(A), "000000") '8) Stunde
Wert = Wert & "H " '9) fix plus Leerzeichen
Wert = Wert & "APL-XX00" '10) fix
Wert = Wert & "0004" '11) fix
Wert = Wert & "L72 " '12) fix plus Leerzeichen
LTMP = 12
TMP = Left(Cells(Z1 - 1, j), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng)
Wert = Wert & TMP & Leer '13) Aufgabe +Leerzeichen Max 12 Zeichen
Wert = Wert & Format(Arr14(A), "0000") '14) Aufgabentyp
Wert = Wert & " " '15) fix 4 Leerzeichen
LTMP = 13
TMP = Left(Arr16(A), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng) & "*"
Wert = Wert & TMP & Leer '16) Kommentar immer 13 +*
Case False 'mit Buchstaben
Wert = "LP" '1) fix
Wert = Wert & "N" '2) fix
Wert = Wert & "ST" '3) fix
Wert = Wert & Format(Nr + 1, "00000000") '4) laufende Nummer
LTMP = 10
TMP = Left(Range("D2"), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng)
Wert = Wert & TMP & Leer '5) Personalnummer plus Leerzeichen Max 10
Wert = Wert & Format(Cells(i, 2), "DDMMYYYY") '6) Datum
Wert = Wert & Format(Cells(i, 2), "DDMMYYYY") '7) Datum2
Wert = Wert & Format(Arr08(A), "000000") '8) Stunde
Wert = Wert & "H " '9) fix plus Leerzeichen (10, 11 entfällt)
Wert = Wert & "L72 " '12) fix plus Leerzeichen
LTMP = 24
TMP = Left(Cells(Z1 - 1, j), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng)
Wert = Wert & TMP & Leer '13) Aufgabe +Leerzeichen Max 24 Zeichen
'--- '(14, 15 entfällt)
LTMP = 21
TMP = Left(Arr16(A), LTMP)
Lng = Len(TMP)
Leer = WF.Rept(" ", LTMP - Lng) & "*"
Wert = Wert & TMP & Leer '16) Kommentar immer 21 +*
End Select
End Select
Print #1, Wert
Nr = Nr + 1 'neue Laufnummer
Next A
End If 'Datum
End If 'leer
Next j
Next i
Close #1
MsgBox "Fertig: " & Nr - LastNr & " Datensätze erzeugt."
LastNr = Nr 'Laufnummer merken
End Sub
LG UweD