Sub Stueli_Standard()
'Formartiert TXT-File vom SAP (ZSTLF) und speichert die Stückliste als xlsx im Pfad "G:\ _
DATENAUSTAUSCH_HELIX-ACAD\Stückliste" ab!
' Letzte Änderung: 20.02.2018
Dim oFileDialog As FileDialog
Dim strStartPath As String
strStartPath = "G:\DATENAUSTAUSCH_HELIX-ACAD\Stückliste"
' \\SERVER-SO-29\clientdaten\kob\AutoCAD\kob.schnabel\DATENAUSTAUSCH_HELIX-ACAD\Stückliste
Set oFileDialog = Application.FileDialog(msoFileDialogOpen)
With oFileDialog
.Title = "Hola, que tal? Welche Textdatei soll geöffnet werden?"
.InitialFileName = strStartPath & "\*.txt"
.AllowMultiSelect = False
If .Show = True Then
path = oFileDialog.SelectedItems(1)
End If
Workbooks.Open Filename:=path
End With
'___________________________________________Hier werden die Spaltenbreiten _
erstellt____________________________________________________________________
'______________________________________________________________________________________________________________________________________________________
Workbooks.OpenText Filename:=path, Origin:=28591, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1) _
, Array(1, 1), Array(4, 1), Array(5, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, _
_
1), Array(58, 1), Array(72, 1), Array(88, 1), Array(90, 1)), TrailingMinusNumbers:= _
True
'_________________Hier wird die Zeile ausgeschnitten um die Identnummern, Benennungen und _
Sachnummern der Zussen zu generieren_________________________
'______________________________________________________________________________________________________________________________________________________
Range("M1").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(RC[-12],RC[-11],RC[-10],RC[-9],RC[-8],RC[-7],RC[-6],RC[-5],RC[-4])"
Selection.Copy
Range("N1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("N:N").EntireColumn.AutoFit
Columns("N:N").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("N1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(8, 1), Array(53, 1)), TrailingMinusNumbers:= _
True
Columns("N:P").Select
Columns("N:P").EntireColumn.AutoFit
Range("N1").Cut Destination:=Range("D1")
Range("O1").Cut Destination:=Range("H1")
Range("P1").Cut Destination:=Range("I1")
Range("F1").ClearContents
Range("B1").ClearContents
'_____________________________________________Ab hier werden die Spalten sortiert und gelö _
scht_________________________________________________________
' _
______________________________________________________________________________________________________________________________________________________
Columns("B:B").Cut Destination:=Columns("A:A") 'Inhalt Spalte _
B wird in Spalte A verschoben
Columns("K:K").Cut Destination:=Columns("B:B")
Columns("D:D").Cut Destination:=Columns("C:C")
Columns("H:H").Cut Destination:=Columns("D:D")
Columns("I:I").Cut Destination:=Columns("E:E")
Columns("G:M").Delete Shift:=xlToLeft 'Inhalt von _
Spalte G bis L wird gelöscht
'________________________________________________Oben eine Zeile einfügen für die Ü _
berschrift__________________________________________________________
'______________________________________________________________________________________________________________________________________________________
Rows("1:1").Insert Shift:=xlDown
'_______________________________________________'Hier wird die Kopfzeile je nach Sprache _
erstellt______________________________________________________
'______________________________________________________________________________________________________________________________________________________
'DEUTSCH___________________________________________________
Dim Dateiname 'Erstellt Variable " _
Dateiname"
Dateiname = ActiveSheet.Name 'Dateiname ist der _
Name vom aktiven Blatt (Reiter unten)
If Right(Dateiname, 1) = "D" Then 'Beginn der Schleife - _
Ist der erste Buchstabe von Rechts ein "D"
Cells(1, 1) = "POS" 'dann mache die Ü _
berschriften auf deutsch
Cells(1, 2) = "Stck."
Cells(1, 3) = "Ident-Nr."
Cells(1, 4) = "Benennung"
Cells(1, 5) = "Sachnummer"
Cells(1, 6) = "E/V"
'ENGLISCH___________________________________________________
ElseIf Right(Dateiname, 1) = "E" Then 'Beginn der Schleife - _
Ist der erste Buchstabe von Rechts ein "E"
Cells(1, 1) = "POS" 'dann mache die Ü _
berschriften auf englisch
Cells(1, 2) = "AMT."
Cells(1, 3) = "ID-NO."
Cells(1, 4) = "DESIGNATION"
Cells(1, 5) = "ARTICLE CODE"
Cells(1, 6) = "W/S"
'ITALIENISCH___________________________________________________
ElseIf Right(Dateiname, 1) = "I" Then 'Beginn der Schleife - _
Ist der erste Buchstabe von Rechts ein "I"
Columns("C:C").Select 'dann mache die Ü _
berschriften auf italienisch
Selection.ColumnWidth = 17
Columns("E:E").Select
Selection.ColumnWidth = 14
Rows("1:1").Select
Selection.RowHeight = 26
Cells(1, 1) = "Pezzo"
Cells(1, 2) = "AMT."
Cells(1, 3) = "NUMERO DI" & Chr(10) & "IDENTIFICAZIONE"
Cells(1, 4) = "DENOMINAZIONE"
Cells(1, 5) = "NUMERO DI" & Chr(10) & "ARTICOLO"
Cells(1, 6) = "Us./ric."
'PORTUGISISCH___________________________________________________
ElseIf Right(Dateiname, 1) = "P" Then 'Beginn der Schleife - _
Ist der erste Buchstabe von Rechts ein "P"
Columns("C:C").Select 'dann mache die Ü _
berschriften auf portugisisch
Selection.ColumnWidth = 17
Columns("E:E").Select
Selection.ColumnWidth = 14
Rows("1:1").Select
Selection.RowHeight = 26
Cells(1, 1) = "Posição"
Cells(1, 2) = "Número de" & Chr(10) & "Peças"
Cells(1, 3) = "identificação"
Cells(1, 4) = "Designação"
Cells(1, 5) = "Número de" & Chr(10) & "Peça"
Cells(1, 6) = "D/S"
'SPANISCH___________________________________________________
ElseIf Right(Dateiname, 1) = "S" Then 'Beginn der Schleife - _
Ist der erste Buchstabe von Rechts ein "S"
Columns("C:C").Select 'dann mache die Ü _
berschriften auf spanisch
Selection.ColumnWidth = 17
Columns("E:E").Select
Selection.ColumnWidth = 14
Rows("1:1").Select
Selection.RowHeight = 26
Cells(1, 1) = "POSICION"
Cells(1, 2) = "CANTIDAD"
Cells(1, 3) = "NÚMERO" & Chr(10) & "DE IDENT"
Cells(1, 4) = "DESCRIPCION"
Cells(1, 5) = "Parte número-"
Cells(1, 6) = "D/R"
'FRANZÖSISCH___________________________________________________
ElseIf Right(Dateiname, 1) = "F" Then 'Beginn der Schleife - _
Ist der erste Buchstabe von Rechts ein "F"
Columns("C:C").Select 'dann mache die Ü _
berschriften auf französisch
Selection.ColumnWidth = 17
Columns("E:E").Select
Selection.ColumnWidth = 14
Rows("1:1").Select
Selection.RowHeight = 26
Cells(1, 1) = "Pos."
Cells(1, 2) = "Nombre De" & Chr(10) & "Pièces"
Cells(1, 3) = "No. D'identité"
Cells(1, 4) = "Désignation"
Cells(1, 5) = "No. De" & Chr(10) & "produit"
Cells(1, 6) = "U/R"
'POLNISCH___________________________________________________
ElseIf Right(Dateiname, 1) = "L" Then 'Beginn der Schleife - _
Ist der erste Buchstabe von Rechts ein "L"
Columns("C:C").Select 'dann mache die Ü _
berschriften auf polnisch
Selection.ColumnWidth = 17
Columns("E:E").Select
Selection.ColumnWidth = 14
Rows("1:1").Select
Selection.RowHeight = 26
Cells(1, 1) = "POZYCJA"
Cells(1, 2) = "SZTUKA"
Cells(1, 3) = "NUMER" & Chr(10) & "IDENTYFIKACYJNY"
Cells(1, 4) = "NAZWA"
Cells(1, 5) = "NUMER CZ" & ChrW(280) & ChrW(346) & "CI"
Cells(1, 6) = "CE/CZ"
End If
'_______________________Hier wird die Zeile gelöscht, in der das Wort Dummy....usw steht und wo _
der Satz mit "Fert am ...." beginnt______________________
'________________________________________________________________________________________________________________________________________________________
Range("D1:D5").Select
For Each cell In Selection
If cell.Value Like "*Fert*am *" Then cell.EntireRow.Delete
Next
Range("D5:D130").Select
For Each cell In Selection
If cell.Value Like "KONTROLLDORN*" Then cell.EntireRow.Delete
Next
Range("D1:A150").Select
For Each cell In Selection
If cell.Value = "999" Then cell.EntireRow.Delete
Next
Range("B3:B5").Select
For Each cell In Selection
If cell.Value = "" Then cell.EntireRow.Delete
Next
Range("A3:A5").Select
For Each cell In Selection
If cell.Value = "0" Then cell.EntireRow.Delete
Next
Range("D1:D20").Select
For Each cell In Selection
If cell.Value Like "Dumm*" Then cell.EntireRow.Delete
Next
'____________________________________Hier wird Ersatz- und Verschleißteile angepasst in den _
verschiedensten Sprachen___________________________________
'______________________________________________________________________________________________________________________________________________________
Range("G3").Select
ActiveCell.FormulaR1C1 = _
"=SUBSTITUTE(SUBSTITUTE(RC[-1],""L"",TRIM(MID(SUBSTITUTE(R1C[-1],""/"",REPT("" "",98)), _
1,98))),""X"",TRIM(MID(SUBSTITUTE(R1C[-1],""/"",REPT("" "",98)),99,98)))"
Dim Ende As Long
With ActiveSheet
Ende = .Cells(.Rows.Count, 6).End(xlUp).Row 'Hier wird _
in Spalte G ab Zeile 3 eine Formel nach unten gezogen bis letztem Eintrag in der Spalte F
.Range("G3").AutoFill Destination:=Range("G3:G" & Ende), Type:=xlFillDefault
End With
Range(Cells(3, 7), Cells(Rows.Count, 7).End(xlUp)).Select 'Hier wird _
in Spalte F ab Zeile 3 alles markiert bis zum letzten Eintrag
Selection.Copy
Range("F3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("G:G").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
'______________________________________________Hier wird der Text in Zeile 1 formatiert (Fett, _
zenriert)________________________________________________
'_______________________________________________________________________________________________________________________________________________________
Range("A1:F2").Select 'markiert Zeile 1 _
Spalte A bis E
Selection.Font.Bold = True 'macht den Text Fett
Selection.HorizontalAlignment = xlCenter 'zentriert den Text
Columns("G:H").ClearContents 'markiert die Spalten G _
und H löscht die zuvor markierten Spalten
Columns("A:F").EntireColumn.AutoFit 'markiert Zeile 1 _
Spalte A bis E passt Spaltenbreite an Text an
'____________________________Ab hier wird Stueckliste markiert, Rahmen/Tabelle gezeichnet und _
Druckbereich zugewiesen__________________________________
'______________________________________________________________________________________________________________________________________________________
Range("A1:F" & Cells(Rows.Count, 1).End(xlUp).Row).Select
'Selection.CurrentRegion.Select 'markiert alle Spalten- _
Zeilen, worin Text enthalten ist um Tabelle drum rum zu zeichen
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous 'zeichnet in markierten _
Spalten die senkrechten linien
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous 'zeichnet in markierten _
Spalten die waagrerechten linien
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
ActiveSheet.PageSetup.PrintArea = Selection.CurrentRegion.Address 'weist Druckbereich zu
'__________________________________________Ab hier Seiteneinrichtung (Kopf und Fußzeile) _
_______________________________________________________________
'______________________________________________________________________________________________________________________________________________________
With ActiveSheet.PageSetup
.LeftHeader = "" 'Fügt in Kopfzeile Links " _
Gewünschten Text"
.CenterHeader = "&F" 'Fügt in Kopfzeile Mitte " _
Dateipfad ein"
.LeftFooter = "MAG / H. Ivanusevic" 'Fügt in Fußzeile Links " _
Gewünschten Text" ein
.CenterFooter = "&P - &N" 'Fügt in Fußzeile Mitte " _
Seite von Seiten" ein
.CenterHorizontally = True
.RightFooter = "13.02.2018" 'Fügt in Fußzeile Rechts " _
Datum" ein
End With
'________________________________________Erstellt Variablen "Dateiname" aus dem aktiven _
Blattregister__________________________________________________
'______________________________________________________________________________________________________________________________________________________
Dateiname = ActiveSheet.Name 'Dateiname ist der Name _
vom aktiven Blatt (Register unten)
If Left(Dateiname, 2) = "00" Then 'Beginn der Schleife - _
Sind im Dateiname am Anfang (von lins) 2 0 (Nullen)
Dateiname = Mid(Dateiname, 3) 'Dann von diesem _
Dateinamen ab der 3. Stelle Wort als Dateinamen verwenden
ElseIf Left(Dateiname, 1) = "0" Then 'Ist im Dateiname am _
Anfang 1 0 (Null)
Dateiname = Mid(Dateiname, 2) 'Dann von diesem _
Dateinamen ab der 2. Stelle wort als Dateinamen verwenden
End If 'Ende der Schleife
ActiveSheet.Name = Dateiname
ActiveWorkbook.SaveAs Filename:="G:\DATENAUSTAUSCH_HELIX-ACAD\Stückliste\" & Dateiname & _
".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'____________Hier wird gefragt, ab welcher Zeile gelöscht werden soll (diese und alle darunter _
folgenden ausgefüllten Zeilen/Zellen)__________________
'______________________________________________________________________________________________________________________________________________________
Selection.End(xlDown).Select
Selection.End(xlDown).Select 'Letzte Zelle in Zeilen _
wird markiert (also nach unten)
Antwort = Msgbox("Markier- und Löschvorgang starten", vbYesNo) 'MsgBox geht _
auf mit Abfrage Ja oder Nein für Markierung
j = 1 'j wird auf 1 gesetzt
If Antwort = vbYes Then 'wurde ja gedrückt?
j = InputBox("Bitte Zeilenummer eingeben") 'Wenn Markierung "JA", _
dann geht Inputbox auf und hier Zeilennummer eingeben,
Do Until Cells(j, 1) = "" _
'ab wo gelöscht werden soll
Rows(j).Delete
Loop
Else
'MsgBox "Markiervorgang abgebrochen!"
End If
'_________________________________Dateiname wird in Zelle C2 eingefügt und Länderkennung wird _
entfernt__________________________________________________
'______________________________________________________________________________________________________________________________________________________
ActiveSheet.Range("C2").Value = ActiveSheet.Name
Range("C2").Select 'Entfernt im _
Namen das Länderkürzel
ActiveCell.Replace What:="_D", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C2").Select 'Entfernt im _
Namen das Länderkürzel
ActiveCell.Replace What:="_E", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C2").Select 'Entfernt im _
Namen das Länderkürzel
ActiveCell.Replace What:="_F", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C2").Select 'Entfernt im _
Namen das Länderkürzel
ActiveCell.Replace What:="_L", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C2").Select 'Entfernt im _
Namen das Länderkürzel
ActiveCell.Replace What:="_I", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'_________________________Sachnummer wird vervollständigt, falls die ersten Zahlen der _
Sachnummer eine Spalte zuvor drinnen stehen________________________
'_________________________________________________________________________________________________________________________________________________________
Columns("A:F").EntireColumn.AutoFit
Range("A1").Select
A = Msgbox("SACHNUMMER ERSTELLEN", vbYesNo) 'Abfrage, ob _
Sachnummer vervollständigt werden soll
If A = vbYes Then 'Ja, dann _
folgenden Code abarbeiten
Range("H2").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-4],FIND("" "",RC[-4]))"
Range("I2").Select
ActiveCell.FormulaR1C1 = "=TRIM(RC[-1])"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],RC[-5])"
Range("J2").Select
Selection.Copy
Range("E2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("H2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=LEFT(RC[-4],FIND("" "",RC[-4])-1)"
Range("H2").Select
Selection.Copy
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("G:J").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Else
B = Msgbox("Weitere Stückliste konvertieren?", vbYesNo) 'Abfrage, ob _
weitere Stüli konvertiert werden soll
If B = vbYes Then Call Stueli_Standard
If B = vbNo Then Exit Sub
End If
'__________________________________________Spalten A bis F werden angepasst, Markierung auf _
A1______________________________________________________________________
'______________________________________________________________________________________________________________________________________________________
Columns("A:F").EntireColumn.AutoFit 'Wird OBEN Nein ( _
bei Sachnummer)geklickt, läuft das makro ab hier weiter
Range("A1").Select
c = Msgbox("Weitere Stückliste konvertieren?", vbYesNo) 'Noch eine Stückliste konvertien
If c = vbNo Then Exit
Sub 'Wenn Nein, dann Programm ENDE
If c = vbYes Then Call Stueli_Standard 'Wenn JA, dann startet das Makro wieder von vorne
End Sub