AW: fast geschafft..
08.03.2022 15:57:53
UweD
Hi
- XYZ wird jetzt ausgelassen
- Läuft ab Spalte O
- Habe die Ermittlung der Anzahl Spalten abgeändert >> läuft jetzt bis DC
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
'*** Vorgaben
Pfad = "C:\Users\Hermann\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
'*** 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
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)
Arr14 = Split(Cells(i, j), vbLf)
Arr16 = Split(Cells(i, j + 2), vbLf)
For A = 0 To UBound(Arr08) 'Wiederholung wenn mehrere Zeilen in Zelle
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 +*
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 & " Datensätze erzeugt."
End Sub
LG UweD