dank einer Hilfe aus diesem Forum haben wir bereits ein Macro erhalten um aus dieser Datei: (siehe nachfolgenden Link)
https://www.herber.de/bbs/user/95213.xls
diese Datei zu erstellen: (siehe nachfolgenden Link)
https://www.herber.de/bbs/user/95214.xls
Allerdings gibt es noch ein Problem, es wird immer eine Postion zu wenig angezeigt.
Die Datei müsste so ausgegeben werden: (siehe nachfolgenden Link)
https://www.herber.de/bbs/user/95215.xls
Hier nun das Macro dazu, vielleicht hat ja jemand einen nützlichen Tipp was wir daran noch umändern müssen, damit wir die Datei wie im dritten Link ausgeben können.
Vielen Dank schon einmal im voraus.
Sub start()
'Kopfzeile wie bereits umgesetzt
Call Header_Zeile
lz = Sheets(1).Cells(65536, 1).End(xlUp).Row
'Datenzeilen
anzahl = 0
For zeile = 2 To lz
anzahl = anzahl + 1
ausgabezeile = ""
'1. Feld
dummy = Sheets(1).Cells(zeile, 1)
For x = Len(dummy) + 1 To 5 'Leerzeichen auffüllen
dummy = dummy & " "
Next x
ausgabezeile = ausgabezeile & dummy
'2. Feld
dummy = Sheets(1).Cells(zeile, 2)
For x = Len(dummy) + 1 To 7 'Leerzeichen auffüllen
dummy = dummy & " "
Next x
ausgabezeile = ausgabezeile & dummy
'3. Feld
dummy = Sheets(1).Cells(zeile, 3)
For x = Len(dummy) + 1 To 6 'Leerzeichen auffüllen
dummy = dummy & " "
Next x
ausgabezeile = ausgabezeile & dummy
'4. Feld
dummy = Sheets(1).Cells(zeile, 4)
For x = Len(dummy) + 1 To 20 'Leerzeichen auffüllen
dummy = dummy & " "
Next x
ausgabezeile = ausgabezeile & dummy
'ausgeben
Sheets(2).Cells(zeile, 1) = ausgabezeile
Next zeile
'Fusszeile... (S + BestellNr + Anzahl-Positionen)
bestellNr = "S" & Sheets(1).Cells(1, 13) 'Bestellnr steht in Zeile 1, Spalte 13
For x = Len(bestellNr) + 1 To 11 'Leerzeichen auffüllen
bestellNr = bestellNr & " "
Next x
Sheets(2).Cells(lz, 1) = bestellNr & anzahl
End Sub
Sub Header_Zeile()
Dim i As Integer, arr(1 To 313)
Dim arrStart, j As Integer
'Startpositionen
arrStart = Array("", 1, 11, 19, 27, 37, 40, 74, 107, 145, 180, 190, 225, 297)
'Array mit Leerzeichen
For i = 1 To 313
arr(i) = Chr(32)
Next i
With Sheets(1)
For j = 1 To 13 'A1:H1 abklappern
For i = 1 To Len(.Cells(1, j))
'Leerzeichen durch Buchstaben ersetzen
arr(i + arrStart(j) - 1) = Mid(.Cells(1, j), i, 1)
Next i
Next j
End With
'Text ausgeben
Sheets(2).Cells(1, 1) = Join(arr, "")
End Sub