Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1872to1876
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

txt.Datei erzeugen (altes Thema)

txt.Datei erzeugen (altes Thema)
08.03.2022 10:02:35
Herrmann
Hallo Zusammen,
ich möchte gerne ein altes Thema "eine txt.Datei erzeugen" wieder öffnen, da ich paar Funktionen noch ergänzen möchte (siehe bei "Erweiterung möglich?") und hoffe auf eure Unterstützung.
Ich weiß leider nicht inwiefern das alte Thread gesehen wird, da es letzte Woche abgeschlossen war. Verzeiht die Wiederholung.
https://www.herber.de/forum/cgi-bin/callthread.pl?index=1873378
Danke im Voraus und LG!

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: txt.Datei erzeugen (altes Thema)
08.03.2022 11:55:41
UweD
Hallo Nochmal
Habe mein letztes Makro erweitert.
- Mehrere Zeilen in einer Zelle bei Aufgabentyp (14), Stunden (8) und Kommentar (16) werden nun aufgesplittet und in mehrere Zeilen verteilt
- Die Aufgabe (Wert 13) wurde schon immer so wie eingetragen verwendet (siehe I5)

Option Explicit
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
'*** Vorgaben
Pfad = "E:\Excel\Temp\" 'mit \ am Ende
Datei = "Ausgabe.txt"
Z1 = 6 'beginne ab Zeile
Sp1 = 9 'Start ab Spalte I
'*** Ende Vorgaben
Set WF = WorksheetFunction
LR = Cells(Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
Close #1
Open Pfad & Datei For Output As 1
Anz = WF.CountA(Rows(Z1 - 1)) 'Anzahl Aufgaben
For i = Z1 To LR
For j = Sp1 To Sp1 + (Anz - 1) * 3 Step 3 'von Spalte I bis O
If Cells(i, j)  "" Then  'nur, wenn nicht leer
'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
Lng = Len(Range("D2"))
Leer = WF.Rept(" ", 10 - Lng)
Wert = Wert & Range("D2") & Leer                '5) Personalnummer plus Leerzeichen
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
Lng = Len(Cells(Z1 - 1, j))
Leer = WF.Rept(" ", 12 - Lng)
Wert = Wert & Cells(Z1 - 1, j) & Leer           '13) Aufgabe +Leerzeichen
Wert = Wert & Format(Arr14(A), "0000")          '14) Aufgabentyp
Wert = Wert & "    "                            '15) fix 4 Leerzeichen
Lng = Len(Left(Cells(i, j + 2), 13))
Leer = WF.Rept(" ", 13 - Lng) & "*"
Wert = Wert & Left(Arr16(A), 13) & Leer         '16) Kommentar immer 13 +*
Print #1, Wert
Nr = Nr + 1 'neue Laufnummer
Next A
End If
Next j
Next i
Close #1
MsgBox "Fertig"
End Sub
LG UweD
Anzeige
Update..
08.03.2022 12:20:33
UweD
Da war ja noch das Thema mit dem Datum.
Ist nun auch eingebaut.

Option Explicit
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
Dim GrDat As Date
'*** Vorgaben
Pfad = "E:\Excel\Temp\" 'mit \ am Ende
Datei = "Ausgabe.txt"
Z1 = 6 'beginne ab Zeile
Sp1 = 9 'Start ab Spalte I
'*** Ende Vorgaben
Set WF = WorksheetFunction
LR = Cells(Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
Close #1
Open Pfad & Datei For Output As 1
Anz = WF.CountA(Rows(Z1 - 1)) 'Anzahl Aufgaben
For i = Z1 To LR
For j = Sp1 To Sp1 + (Anz - 1) * 3 Step 3 'von Spalte I bis O
If Cells(i, j)  "" Then  'nur, wenn nicht leer
'Grenzdatum prüfen
GrDat = DateSerial(Year(Date), Month(Date) - 1, 1)  '01. des Vormonats
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
Lng = Len(Range("D2"))
Leer = WF.Rept(" ", 10 - Lng)
Wert = Wert & Range("D2") & Leer                '5) Personalnummer plus Leerzeichen
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
Lng = Len(Cells(Z1 - 1, j))
Leer = WF.Rept(" ", 12 - Lng)
Wert = Wert & Cells(Z1 - 1, j) & Leer           '13) Aufgabe +Leerzeichen
Wert = Wert & Format(Arr14(A), "0000")          '14) Aufgabentyp
Wert = Wert & "    "                            '15) fix 4 Leerzeichen
Lng = Len(Left(Cells(i, j + 2), 13))
Leer = WF.Rept(" ", 13 - Lng) & "*"
Wert = Wert & Left(Arr16(A), 13) & 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
Anzeige
fast geschafft..
08.03.2022 12:53:42
Herrmann
Hallo UweD,
vielen vielen Dank, dass du dich nochmal dazu schaltest. Hat soweit funktioniert.
- Ich konnte jetzt das Problem finden, weshalb eine Fehlermeldung bei der Aufgabe (Feld 13.) kam. Tut mir leid, da hattest du zwar recht aber der meckert, wenn die Zelle über 12 Zeichen beinhaltet. Bei zu wenigen werden (wie gewollt) Leerzeichen gesetzt aber bei zu vielen Zeichen kommt eine Fehlermeldung..
- Ich konnte noch beobachten, dass wenn ich ein im Kommentarfeld (16) ein Zeilenumbruch habe mit wenig Zeichen, verschiebt sich das Format.
Ich habe die Beispieldatei nochmal anhand der Fehler überarbeitet. Wenn du auf das Button klickst, wirst du die Fehlermeldung sehen: https://www.herber.de/bbs/user/151630.xlsm
txt.Datei (bzgl. Kommentarfeld (16)) siehe Zeile 2 und 3: https://www.herber.de/bbs/user/151631.txt
Danke im Voraus
LG!
Anzeige
AW: fast geschafft..
08.03.2022 14:08:36
UweD
Noch ein Versuch

Option Explicit
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
'*** Vorgaben
'Pfad = "E:\Excel\Temp\" 'mit \ am Ende
Pfad = "C:\Users\Hermann\Desktop\" 'mit \ am Ende
Datei = "Ausgabe.txt"
Z1 = 6 'beginne ab Zeile
Sp1 = 9 'Start ab Spalte I
'*** Ende Vorgaben
Set WF = WorksheetFunction
LR = Cells(Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
Close #1
Open Pfad & Datei For Output As 1
Anz = WF.CountA(Rows(Z1 - 1)) 'Anzahl Aufgaben
For i = Z1 To LR
For j = Sp1 To Sp1 + (Anz - 1) * 3 Step 3 'von Spalte I bis O
If Cells(i, j)  "" Then  'nur, wenn nicht leer
'Grenzdatum prüfen
GrDat = DateSerial(Year(Date), Month(Date) - 1, 1)  '01. des Vormonats
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
Anzeige
AW: fast geschafft..
08.03.2022 15:11:06
Herrmann
Hallo UweD,
ich bin dir sehr dankbar!
Ich habe es in meine Orginaldatei eingefügt und es läuft, hammer :)
Ich habe nur noch paar abschließende Fragen:
- Das Makro läuft (in der Orgnialdatei) ab Spalte O bis DC, dazwischen befindet sich also die Spalte X, Y und Z. Ist es möglich diese drei Spalten nicht einzubeziehen?
- Mein Arbeitsblatt geht bis zur Spalte DL (in Zunkunft wahrscheinlich noch weiter) aber die txt.Datei läuft nur bis ungefähr zur Spalte DC, woran liegt das?
Danke im Voraus für deine Bemühungen.
LG
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 &GT&GT 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
Anzeige
Läuft auch bis DL ( bzw bis zum Ende )
08.03.2022 16:02:00
UweD
nicht wie geschrieben bis DC
Danke!
08.03.2022 16:07:33
Herrmann
Vielen vielen Dank UweD! funktioniert alles einwandfrei.
LG
Schwere Geburt...
08.03.2022 16:17:36
UweD
aber prima, dass es jetzt läuft.

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige