|
Hallo VBA Community,
seit einigen Tagen habe ich Probleme mit dem Ausführen eines meiner Makros in einem Excel Kalkulations file.
Der "Laufzeitfehler 1004" erscheint kurz vor abschliessen der Transformation und verhindert somit das vollständige Formatieren der Basisdatei in ein geplantes Ausgabeformat für unsere Kunden.
Ich habe das Gefühl, dass dies auf eines der letzten Microsoft Updates zurückzuführen ist und nichts mit dem Quellcode zu tun hat, wecher in den letzten Wochen nicht adaptiert wurde und bis vor wenigen Tagen tadellos funktioniert hat.
Hat jemand von euch ähnliche Erfahrungen gemacht und hat vielleicht einen Lösungsansatz für mich?
P.S. Ich weiiss, der Code ist nicht der eleganteste aber er funktioniert. Bin jedoch für Vorschläge durchaus offen.
Beste Grüsse
Andreas
'================================================================================================================
'Kopieren der Kalkulation und Reduzierung auf das Ausgabe-Format für den Kunden mit festen (unveränderlichen) Zahlenwerten
'================================================================================================================
Sub DeviErstellen()
Dim Response As String
Response = MsgBox("Achtung! Mit diesem Befehl wird die Kalkulation in das Ausgabe-Format für den Kunden übertragen. Hierbei wird ein ggf. bereits bestehendes Devi vollständig Ùberschrieben!", vbOKCancel, "Ausführung bestätigen")
If Response = vbCancel Then Exit Sub
Application.ScreenUpdating = False
'Sofern vorhanden, altes Devi loeschen
On Error GoTo NeuesDevi
Sheets("Kunden-Devi").Select
On Error GoTo 0
Application.DisplayAlerts = False
Sheets("Kunden-Devi").Delete
Application.DisplayAlerts = True
NeuesDevi:
Sheets("KALK").Select
Sheets("KALK").Copy After:=Sheets("IV")
Sheets("KALK (2)").Select
Sheets("KALK (2)").Name = "Kunden-Devi"
'Grafische Anpassung des kopierten KALK-Sheets auf die Ausgabe-Struktur
ActiveSheet.Unprotect "unchained"
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Rows("55:5000").Select
Selection.UnMerge
Rows("24:24").Select
Selection.ClearComments
Range("G25:R26").Select
Selection.ClearContents
Cells.Select
Selection.FormatConditions.Delete
Columns("HM:HM").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="D"
Rows("55:5000").Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=1
Selection.AutoFilter
Columns("HN:IP").Select
Selection.Delete
Columns("S:HL").Select
Selection.Delete
Rows("1:74").Select
Selection.EntireRow.Hidden = False
Rows("37:74").Select
Selection.Delete Shift:=xlUp
Rows("22:23").Select
Selection.Delete Shift:=xlUp
Rows("2:19").Select
Selection.Delete Shift:=xlUp
Columns("S:S").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="V"
Selection.Activate
Rows("2:7").Select
Selection.RowHeight = 21
Rows("8:14").Select
Selection.RowHeight = 15
ActiveWindow.FreezePanes = False
ActiveWindow.DisplayZeros = (ActiveWindow.DisplayZeros = False)
'Loeschen der Buttons
If ActiveSheet.Shapes("btnAus").Visible = False Then ActiveSheet.Shapes("btnAus").Visible = True
If ActiveSheet.Shapes("btnEin").Visible = False Then ActiveSheet.Shapes("btnEin").Visible = True
ActiveSheet.Shapes("Button 1").Select
Selection.Delete
ActiveSheet.Shapes("Button 2").Select
Selection.Delete
ActiveSheet.Shapes("Button 3").Select
Selection.Delete
ActiveSheet.Shapes("Button 4").Select
Selection.Delete
ActiveSheet.Shapes("Button 5").Select
Selection.Delete
ActiveSheet.Shapes("Button 6").Select
Selection.Delete
ActiveSheet.Shapes("Button 7").Select
Selection.Delete
ActiveSheet.Shapes("Button 8").Select
Selection.Delete
ActiveSheet.Shapes("Button 9").Select
Selection.Delete
ActiveSheet.Rows.Ungroup
ActiveSheet.Columns.Ungroup
'Optische Anpassungen im Kopfbereich
Range("G2:P4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
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
Range("B2:P4").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
ActiveSheet.Shapes.Range(Array("Picture 14")).Select
Selection.ShapeRange.IncrementTop 10
Columns("E:H").EntireColumn.Hidden = True
'Einblenden des Wechselkurses sofern eine andere Ausgabewährung vorhanden ist
If ActiveSheet.Range("Q6") <> 0 Then
ActiveSheet.Range("Q4") = "Wechselkurs: 1 " & ActiveSheet.Range("Q6") & " = " & ActiveSheet.Range("r6") & " CHF"
ActiveSheet.Range("Q4").Select
With Selection.Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0.349986266670736
.Size = 8
End With
End If
'Druck im A4-Format anpassen
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$13"
.PrintTitleColumns = "$A:$A"
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$A:$R"
' Application.PrintCommunication = False
' With ActiveSheet.PageSetup
' .LeftHeader = ""
' .CenterHeader = ""
' .RightHeader = "&D"
' .LeftFooter = "&F"
' .CenterFooter = ""
' .RightFooter = "&P | &N"
' .LeftMargin = Application.InchesToPoints(0.118110236220472)
' .RightMargin = Application.InchesToPoints(0.118110236220472)
' .TopMargin = Application.InchesToPoints(0.354330708661417)
' .BottomMargin = Application.InchesToPoints(0.551181102362205)
' .HeaderMargin = Application.InchesToPoints(0.118110236220472)
' .FooterMargin = Application.InchesToPoints(0.31496062992126)
' .PrintHeadings = False
' .PrintGridlines = False
' .PrintComments = xlPrintNoComments
' .PrintQuality = 600
' .CenterHorizontally = False
' .CenterVertically = False
' .Orientation = xlPortrait
' .Draft = False
' .PaperSize = xlPaperA4
' .Order = xlDownThenOver
' .BlackAndWhite = False
' .Zoom = False
' .FitToPagesWide = 1
' .FitToPagesTall = False
' .PrintErrors = xlPrintErrorsDisplayed
' .OddAndEvenPagesHeaderFooter = False
' .DifferentFirstPageHeaderFooter = False
' .ScaleWithDocHeaderFooter = True
' .AlignMarginsHeaderFooter = True
' End With
' Application.PrintCommunication = True
Range("A1").Select
End Sub
|