AW: Makro lässt sich nach Speichern nicht ausführe
28.10.2007 12:04:05
Anja
Hallo Tino,
das zweite Makro sieht wie folgt aus
Sub Makro_Fuer_BLZMS()
' Zur
' Makro am 09.09.2007 von Anja aufgezeichnet
' Tastenkombination: Strg+Umschalt+A
' Allgemeines Tabellenformat: Zwei Zeilen löschen,
' Überschriften einfügen, automatische Spaltenbreite:
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
ActiveCell.FormulaR1C1 = "FA_Nr."
Range("B1").Select
ActiveCell.FormulaR1C1 = "Kundenauftr.-Nr."
Range("C1").Select
ActiveCell.FormulaR1C1 = "Pos."
Range("D1").Select
ActiveCell.FormulaR1C1 = "Termin"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Menge"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Bezeichnung_1"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Bezeichnung_2"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
' Vor Spalte acht weitere Spalten einfügen:
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
' Spalte F so gestalten, daß gemeinsamer Trenner"/",
' dann den Text auf die acht Spalten aufteilen und
' formatieren:
Columns("F:F").Select
Selection.Replace What:="-", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="/", Replacement:="/ ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
1), Array(6, 1), Array(7, 1), Array(8, 1))
Range("F1").Select
ActiveCell.FormulaR1C1 = "Baureihe"
Columns("F:F").EntireColumn.AutoFit
Range("G1").Select
ActiveCell.FormulaR1C1 = "Befestigung"
Columns("G:G").EntireColumn.AutoFit
Range("H1").Select
ActiveCell.FormulaR1C1 = "Kolben-Ø"
Columns("H:H").EntireColumn.AutoFit
Range("I1").Select
ActiveCell.FormulaR1C1 = "Stangen-Ø"
Columns("I:I").EntireColumn.AutoFit
Range("J1").Select
ActiveCell.FormulaR1C1 = "Hub"
Columns("J:J").EntireColumn.AutoFit
Range("K1").Select
ActiveCell.FormulaR1C1 = "Funktion"
Columns("K:K").EntireColumn.AutoFit
Range("L1").Select
ActiveCell.FormulaR1C1 = "Kstg.-Ende"
Columns("L:L").EntireColumn.AutoFit
Range("M1").Select
ActiveCell.FormulaR1C1 = "SPS"
Columns("M:M").EntireColumn.AutoFit
Range("N1").Select
ActiveCell.FormulaR1C1 = "SPK"
Columns("N:N").EntireColumn.AutoFit
' Spalte Hub_Geh. einfügen und die im Hub
' in Klammer stehende Zahl dort einlesen:
Columns("L:L").Select
Selection.Insert Shift:=xlToRight
Columns("K:K").Select
Selection.TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="(", FieldInfo:=Array(Array(1, 1), Array(2, 1))
Columns("L:L").Select
Selection.Replace What:=")", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("K1").Select
ActiveCell.FormulaR1C1 = "Hub_Geh."
Columns("K:K").EntireColumn.AutoFit
' Formatierung der Spalten Befestigungsart,
' Hub und Hub_Geh.:
Columns("H:H").Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("L:L").Select
Selection.NumberFormat = "0.00"
Columns("G:G").Select
Columns("J:J").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
' Aus den aus der Bezeichnung_1 ausgelesenen Spalten
' werden die führenden Leerzeichen entfernt:
Columns("G:G").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("H:H").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("I:I").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("J:J").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("K:K").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("L:L").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("M:M").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Columns("N:N").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
' Aus Bezeichnung_2 werden die diversen
' Sonderausstattungs-Spalten erzeugt:
Columns("P:P").Select
Selection.TextToColumns Destination:=Range("P1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
Range("Q1").Select
ActiveCell.FormulaR1C1 = "Sonder_1"
Columns("Q:Q").EntireColumn.AutoFit
Range("R1").Select
ActiveCell.FormulaR1C1 = "Sonder_2"
With ActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Arial"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("R:R").EntireColumn.AutoFit
Range("S1").Select
ActiveCell.FormulaR1C1 = "Sonder_3"
With ActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Arial"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("S:S").EntireColumn.AutoFit
Range("T1").Select
ActiveCell.FormulaR1C1 = "Sonder_4"
With ActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Arial"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("T:T").EntireColumn.AutoFit
Range("U1").Select
ActiveCell.FormulaR1C1 = "Sonder_5"
With ActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Arial"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("U:U").EntireColumn.AutoFit
Range("P1").Select
ActiveCell.FormulaR1C1 = "Textspalte_allgem."
Columns("P:P").EntireColumn.AutoFit
' Nun wird die Terminspalte getrennt in zwei Spalten,
' Kalenderwoche, KW, und Jahr:
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1))
Range("D1").Select
ActiveCell.FormulaR1C1 = "KW"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Jahr"
Range("F1").Select
' Eine neue Spalte Baureihe wird eingefügt, die alten
' Spalten werden umbenannt:
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Range("I1").Select
ActiveCell.FormulaR1C1 = "Baureihe"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Art"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Druck"
Range("I2").Select
Columns("G:I").Select
Selection.ClearFormats
Range("I2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("I2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]&""-""&RC[-1]"
Range("I2").Select
Selection.AutoFill Destination:=Range("I2:I1000"), Type:=xlFillDefault
Range("I2:I1000").Select
' Diverse Spalten werden umbenannt, neu angelegt,
' Spaltenbreite automatisiert:
ActiveWindow.SmallScroll ToRight:=-1
Range("J1").Select
ActiveCell.FormulaR1C1 = "Befestigung"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Kolben-Ø"
Range("L1").Select
ActiveCell.FormulaR1C1 = "Stg.-Ø"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Hub"
Range("N1").Select
ActiveCell.FormulaR1C1 = "Hub_Geh"
Range("O1").Select
ActiveCell.FormulaR1C1 = "Funktion"
Range("P1").Select
ActiveCell.FormulaR1C1 = "Kstg.-Ende"
Range("R1").Select
Selection.EntireColumn.Insert
Selection.EntireColumn.Insert
Selection.EntireColumn.Insert
Selection.EntireColumn.Insert
Selection.EntireColumn.Insert
Selection.EntireColumn.Insert
Range("Q1").Select
ActiveCell.FormulaR1C1 = "Zus_1"
Range("R1").Select
ActiveCell.FormulaR1C1 = "Zus_2"
Range("S1").Select
ActiveCell.FormulaR1C1 = "Zus_3"
Range("T1").Select
ActiveCell.FormulaR1C1 = "Zus_4"
Range("U1").Select
ActiveCell.FormulaR1C1 = "Zus_5"
Range("V1").Select
ActiveCell.FormulaR1C1 = "Zus_6"
Range("W1").Select
ActiveCell.FormulaR1C1 = "Zus_7"
Range("X1").Select
Columns("Q:Q").EntireColumn.AutoFit
Columns("R:R").EntireColumn.AutoFit
Columns("S:S").EntireColumn.AutoFit
Columns("T:T").EntireColumn.AutoFit
Columns("U:U").EntireColumn.AutoFit
Columns("V:V").EntireColumn.AutoFit
Columns("W:W").EntireColumn.AutoFit
Columns("X:X").Select
Selection.Delete Shift:=xlToLeft
'Punkte entfernen:
Dim i As Integer
Dim Spalten As Integer
For Spalten = 1 To 28 'für 1. bis 28. Spalte kannst du ändern
For i = 1 To Cells(Rows.Count, Spalten).End(xlUp).Row
If Right(Cells(i, Spalten), 1) = "." Then Cells(i, Spalten) = Left(Cells(i, Spalten) _
, Len(Cells(i, Spalten)) - 1)
Next i
Next Spalten
Columns("M:M").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Range("L14").Select
' Leerstelle in Spalte T entfernen
Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByColumns, MatchCase:=False
Range("T1").Select
End Sub
Mit diesem Makro passe ich meine xml-Liste für die weitere Bearbeitung an.
Hoffe du kannst mir weiterhelfen.
Grüße Anja