AW: Makro läuft in neuem Workbook nicht weiter
05.09.2010 01:24:16
Urs
Hallo Franz
ich erlaube mir meinem ganzen Code zu veröffentlichen.
Wenn Fehler oder Verbesserungen möglich sind bin ich dankbar um die Tips.
Freundlichen Gruss¨
Urs
Sub Makro6()
'Verarbeitung der ET Tabelle ausgehend von ZVS_ETM
'Makro am 03.09.2010 geschrieben von Urs Schmid mit Hilfe von Franz (fcs) (https://www.herber.de/ _
forum/)
Dim wbHTML As Workbook, wksHTML As Worksheet, filetoopen As Variant
'Rohdaten (MHTML) öffnen
filetoopen = Windows.Application.GetOpenFilename("All Files (*.*), *.*")
If filetoopen = False Then Exit Sub
Set wbHTML = Workbooks.Open(filetoopen)
Set wksHTML = wbHTML.Worksheets(1)
wbHTML.Activate
'Stücklisten # Fett markieren
wksHTML.Columns("B:B").TextToColumns Destination:=wksHTML.Range("B1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
wksHTML.Columns("C:C").TextToColumns Destination:=wksHTML.Range("C1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
wksHTML.Columns("E:E").TextToColumns Destination:=wksHTML.Range("E1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
With wksHTML.Columns("E:E")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
wksHTML.Columns("I:I").NumberFormat = "#,##0.00"
'Neue Spalten einfügen
wksHTML.Columns("F:F").Select 'Für Sprache Deutsch, Englisch & Französisch
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
wksHTML.Columns("K:K").Select 'Für WBZ & ET-Kenner
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
wksHTML.Columns("O:O").Select 'Für Preise
Selection.Insert Shift:=xlToRight 'Wert CHF
Selection.Insert Shift:=xlToRight 'Wert EUR
Selection.Insert Shift:=xlToRight 'Wert GBP
Selection.Insert Shift:=xlToRight 'Wert USD
Selection.Insert Shift:=xlToRight 'Total CHF
Selection.Insert Shift:=xlToRight 'Währung Total CHF
Selection.Insert Shift:=xlToRight 'Total EUR
Selection.Insert Shift:=xlToRight 'Währung Total EUR
Selection.Insert Shift:=xlToRight 'Total GBP
Selection.Insert Shift:=xlToRight 'Währung Total GBP
Selection.Insert Shift:=xlToRight 'Total USD
Selection.Insert Shift:=xlToRight 'Währung Total USD
'Neues Tabellenblatt einfügen und ans Ende stellen
Dim X As String
X = "Sheet4"
Sheets.Add
With ActiveSheet
.Name = X
.Move After:=Sheets(4)
End With
'Tabellenblatt 1 aktivieren
Sheets(1).Activate
'Formeln in Felder kopieren
'Formel für Preis-Gültigkeitsbereich festlegen
wksHTML.Range("B1").FormulaR1C1 = "=""31.12."" & YEAR(TODAY())"
'Dateiname generieren "Ersatzteile Typ M Serie.xls"
wksHTML.Range("A1").FormulaR1C1 = "=""Spare parts "" & R[1]C[] & "" M "" & R[1]C[1]"
'Deutsche Texte werden aus dem Inhalt von 2 Spalten zusammengestellt
wksHTML.Range("F2").FormulaR1C1 = "=If(R[0]C[7]="""",R[0]C[-2],R[0]C[7])"
'Sheet2 wird für Englische Texte verwendet
wksHTML.Range("G2").FormulaR1C1 = "=IF(ISNA(VLOOKUP(R[0]C[-2],Sheet2!R1C1:R3000C3,2,0)),"""" _
,(VLOOKUP(R[0]C[-2],Sheet2!R1C1:R3000C3,2,0)))"
'Sheet3 wird für WBZ verwendet
wksHTML.Range("K2").FormulaR1C1 = "=IF(ISNA(VLOOKUP(R[0]C[-6],Sheet3!R1C1:R40000C3,3,0)),""" _
",(VLOOKUP(R[0]C[-6],Sheet3!R1C1:R40000C3,3,0)))"
'Sheet4 wird für Französische Texte verwendet
wksHTML.Range("H2").FormulaR1C1 = "=IF(ISNA(VLOOKUP(R[0]C[-2],Sheet4!R1C1:R3000C3,2,0)),"""" _
,(VLOOKUP(R[0]C[-2],Sheet4!R1C1:R3000C3,2,0)))"
'Der ET-Kenner wird aus Spalte AB kopiert, der ET-Kenner K00 wird nicht berücksichtigt
wksHTML.Range("L2").FormulaR1C1 = "=If(OR(R[0]C[16]="""",R[0]C[16]=""K00""),"""",R[0]C[16])" _
'Umrechnungsfaktoren in Start Workbook speichern, somit kann man sie einfacher anpassen ---- _
-> noch zu erledigen
wksHTML.Range("O2").FormulaR1C1 = "=IF(R[0]C[12]=""CHF"",R[0]C[-1],R[0]C[-1]*1.45)" _
'Wert CHF berechnen
wksHTML.Range("P2").FormulaR1C1 = "=IF(R[0]C[11]=""CHF"",R[0]C[-2],R[0]C[-2]/1.45)" _
'Wert EUR berechnen
wksHTML.Range("Q2").FormulaR1C1 = "=IF(R[0]C[10]=""CHF"",R[0]C[-3]*0.604085,R[0]C[-3]*0. _
827744)" 'Wert GBP berechnen
wksHTML.Range("R2").FormulaR1C1 = "=IF(R[0]C[9]=""CHF"",R[0]C[-4]*0.604085,R[0]C[-4]*0. _
827744)" 'Wert USD berechnen
wksHTML.Range("S2").FormulaR1C1 _
= "=R[0]C[-4]*R[0]C[-10]" 'Preis Total CHF ermitteln
wksHTML.Range("U2").FormulaR1C1 _
= "=R[0]C[-5]*R[0]C[-12]" 'Preis Total EUR ermitteln
wksHTML.Range("W2").FormulaR1C1 _
= "=R[0]C[-6]*R[0]C[-14]" 'Preis Total GBP ermitteln
wksHTML.Range("Y2").FormulaR1C1 _
= "=R[0]C[-7]*R[0]C[-16]" 'Preis Total USD ermitteln
wksHTML.Range("T2").FormulaR1C1 = "=""CHF""" 'Währung Total CHF
wksHTML.Range("V2").FormulaR1C1 = "=""EUR""" 'Währung Total EUR
wksHTML.Range("X2").FormulaR1C1 = "=""GBP""" 'Währung Total GBP
wksHTML.Range("Z2").FormulaR1C1 = "=""USD""" 'Währung Total USD
'Formeln nach unten kopieren
wksHTML.Range("F2").Copy Destination:=wksHTML.Range("F3:F4010")
wksHTML.Range("G2").Copy Destination:=wksHTML.Range("G3:G4010")
wksHTML.Range("H2").Copy Destination:=wksHTML.Range("H3:H4010")
wksHTML.Range("K2").Copy Destination:=wksHTML.Range("K3:K4010")
wksHTML.Range("L2").Copy Destination:=wksHTML.Range("L3:L4010")
wksHTML.Range("O2").Copy Destination:=wksHTML.Range("O3:O4010")
wksHTML.Range("P2").Copy Destination:=wksHTML.Range("P3:P4010")
wksHTML.Range("Q2").Copy Destination:=wksHTML.Range("Q3:Q4010")
wksHTML.Range("R2").Copy Destination:=wksHTML.Range("R3:R4010")
wksHTML.Range("S2").Copy Destination:=wksHTML.Range("S3:S4010")
wksHTML.Range("T2").Copy Destination:=wksHTML.Range("T3:T4010")
wksHTML.Range("U2").Copy Destination:=wksHTML.Range("U3:U4010")
wksHTML.Range("V2").Copy Destination:=wksHTML.Range("V3:V4010")
wksHTML.Range("W2").Copy Destination:=wksHTML.Range("W3:W4010")
wksHTML.Range("X2").Copy Destination:=wksHTML.Range("X3:X4010")
wksHTML.Range("Y2").Copy Destination:=wksHTML.Range("Y3:Y4010")
wksHTML.Range("Z2").Copy Destination:=wksHTML.Range("Z3:Z4010")
'Titel und erste Zeile fixieren / formatieren
' Titel der Spalten setzen
wksHTML.Range("E1").Select
ActiveCell.FormulaR1C1 = "Art. #"
wksHTML.Range("F1").Select
ActiveCell.FormulaR1C1 = "Text Deutsch"
wksHTML.Range("G1").Select
ActiveCell.FormulaR1C1 = "Text English"
wksHTML.Range("H1").Select
ActiveCell.FormulaR1C1 = "Text Français"
wksHTML.Range("I1").Select
ActiveCell.FormulaR1C1 = "Anzahl / Quantity"
wksHTML.Range("J1").Select
ActiveCell.FormulaR1C1 = "Einheit / Unit"
wksHTML.Range("K1").Select
ActiveCell.FormulaR1C1 = "WBZ / RPT"
wksHTML.Range("L1").Select
ActiveCell.FormulaR1C1 = "ET-Kenner / SPI"
wksHTML.Range("N1").Select
ActiveCell.FormulaR1C1 = "SAP PR00"
wksHTML.Range("O1").Select
ActiveCell.FormulaR1C1 = "CHF"
wksHTML.Range("P1").Select
ActiveCell.FormulaR1C1 = "EUR"
wksHTML.Range("Q1").Select
ActiveCell.FormulaR1C1 = "GBP"
wksHTML.Range("R1").Select
ActiveCell.FormulaR1C1 = "USD"
wksHTML.Range("S1").Select
ActiveCell.FormulaR1C1 = "Total CHF"
wksHTML.Range("T1").Select
ActiveCell.FormulaR1C1 = "Währung / Currancy"
wksHTML.Range("U1").Select
ActiveCell.FormulaR1C1 = "Total EUR"
wksHTML.Range("V1").Select
ActiveCell.FormulaR1C1 = "Währung / Currancy"
wksHTML.Range("W1").Select
ActiveCell.FormulaR1C1 = "Total GBP"
wksHTML.Range("X1").Select
ActiveCell.FormulaR1C1 = "Währung / Currancy"
wksHTML.Range("Y1").Select
ActiveCell.FormulaR1C1 = "Total USD"
wksHTML.Range("Z1").Select
ActiveCell.FormulaR1C1 = "Währung / Currancy"
'Erste Zeile fixieren
wksHTML.Rows("2:2").Select
ActiveWindow.FreezePanes = True
'Erste Zeile formatieren
wksHTML.Rows("1:1").Select
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Interior.ColorIndex = xlNone
Selection.RowHeight = 30#
With Selection
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Autofilter setzen
wksHTML.Cells.AutoFilter
'Stücklisten Fett markieren und ein x in Spalte AC schreiben
Selection.AutoFilter Field:=13, Criteria1:="="
wksHTML.Range("D2:E4010").Select
Selection.Font.Bold = True
With wksHTML.Range("AC2")
.FormulaR1C1 = "x"
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Copy Destination:=wksHTML.Range("AC2:AC4010")
End With
'Währung und Preise bei Stücklisten löschen
wksHTML.Range("O2:O4010").ClearContents 'CHF
wksHTML.Range("P2:P4010").ClearContents 'EUR
wksHTML.Range("Q2:Q4010").ClearContents 'GBP
wksHTML.Range("R2:R4010").ClearContents 'USD
wksHTML.Range("S2:S4010").ClearContents 'CHF Total
wksHTML.Range("T2:T4010").ClearContents 'Währung Total CHF
wksHTML.Range("U2:U4010").ClearContents 'EUR Total
wksHTML.Range("V2:V4010").ClearContents 'Währung Total EUR
wksHTML.Range("W2:W4010").ClearContents 'GBP Total
wksHTML.Range("X2:X4010").ClearContents 'Währung Total GBP
wksHTML.Range("Y2:Y4010").ClearContents 'USD Total
wksHTML.Range("Z2:Z4010").ClearContents 'Währung Total USD
Selection.AutoFilter Field:=13
'Formel: Teile mit ET-Kenner mit x kennzeichnen (K00 nicht beachten)
wksHTML.Range("AD2").FormulaR1C1 = _
"=IF(OR(AND(NOT(RC[-1]=""x""),NOT(RC[-2]0)),RC[-2]=""K00""),"""",""x"")"
'Formeln nach unten kopieren
wksHTML.Range("AD2").Copy Destination:=wksHTML.Range("AD3:AD4010")
'Leere Materialnummern löschen
Selection.AutoFilter Field:=5, Criteria1:="="
wksHTML.Rows("2:4010").Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=5
'Stückzahl = 0 löschen
Selection.AutoFilter Field:=9, Criteria1:="0"
wksHTML.Rows("2:4010").Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=9
'Formatierung der Spalte D in Spalte F, G & H kopieren
wksHTML.Columns("E:E").Select
Selection.Copy
wksHTML.Columns("F:F").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.Copy
wksHTML.Columns("G:G").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.Copy
wksHTML.Columns("H:H").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Spaltenbreiten anpassen
wksHTML.Range("E:E,N:N,AC:AC,AD:AD").EntireColumn.AutoFit
wksHTML.Range("F:F,G:G,H:H").ColumnWidth = 44
wksHTML.Range("I:I,J:J").ColumnWidth = 7.71
wksHTML.Columns("K:K").ColumnWidth = 5.43
wksHTML.Columns("L:L").ColumnWidth = 11#
wksHTML.Range("O:O,P:P,Q:Q,R:R,S:S,T:T,U:U,V:V,W:W,X:X,Y:Y,Z:Z").ColumnWidth = 9.5
'Ausrichtung der Spalten
wksHTML.Range("I:I,J:J,K:K,L:L").Select
With Selection
.HorizontalAlignment = xlCenter
'.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Zellen in der Kopfzeile rechts ausrichten
wksHTML.Range("O1:R1").Select
With Selection
.HorizontalAlignment = xlRight
End With
'Spalten ausblenden
wksHTML.Range("A:A,B:B,C:C,D:D,H:H,M:M,N:N,AA:AA,AB:AB").Select
Selection.EntireColumn.Hidden = True
'Masterdatei öffnen und Sprachdaten pro Zeile auslesen ----> noch zu erledigen
'Masterdatei öffnen und WBZ pro Zeile auslesen -----> noch zu erledigen
'Ausdruck formatieren, Kopf- und Fusszeilen definieren
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&""Arial,Fett""&20Spare parts " & wksHTML.Range("A2").Value & " / " & _
wksHTML.Range("B2").Value
.RightHeader = ""
.LeftFooter = "StarragHeckert AG"
.CenterFooter = "&P / &N"
.RightFooter = "&D" & Chr(10) & "Prices valid until " & "31.12." & wksHTML.Range("B1"). _
Value
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
'Autofilter ausschalten
wksHTML.Cells.AutoFilter
'Autofilter einschaltenn
wksHTML.Cells.AutoFilter
'Aktive Zelle auswählen
wksHTML.Range("E1").Select
' Datei als .xls speichern
With wbHTML
.SaveAs Filename:=.Path & Application.PathSeparator & wksHTML.Cells(1, 1), _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End With
End Sub