Excel Stoppt (hängt) ohne Fehlermeldung
10.10.2017 11:01:26
Thomas
mein Problem liegt darin, wenn ich die Userform aufrufe und ein Makro ausführen möchte, hängt Excel und lässt sich nur durch Alt + F4 beenden.
Vielleicht kann mir jemand weiterhelfen, was Excel nicht mag.
Es kommt auch keine Fehlermeldung ....
Userform:
Private Sub cmd_druck_frueh_Click()
Call SubDrucken("frueh")
Me.Hide
End Sub
Private Sub cmd_druck_mittag_Click()
Call SubDrucken("mittag")
Me.Hide
End Sub
usw...
Sub SubDrucken(Zeit)
Application.ScreenUpdating = False
Dim iRowL As Integer
Dim Bereich As Range
Dim lngLetzteSpalte As Long
Dim druckformat As String
iRowL = Cells(Rows.Count, 1).End(xlUp).Row
Columns("E:E").EntireColumn.Hidden = False
ActiveWorkbook.Worksheets("Anlieferung").ShowAllData ' Alle Daten anzeigen
If Zeit = "frueh" Then '
ActiveWorkbook.Worksheets("Anlieferung").Range("A1:L" & iRowL).AutoFilter Field:=1, _
Criteria1:= _
"=" & CDate(Format(Date, "dd.mm.yyyy"))
ActiveWorkbook.Worksheets("Anlieferung").Range("A1:L" & iRowL).AutoFilter Field:=2, _
Criteria1:="Früh"
druckformat = xlLandscape
End If
If Zeit = "mittag" Then
ActiveWorkbook.Worksheets("Anlieferung").Range("A1:L" & iRowL).AutoFilter Field:=1, _
Criteria1:= _
"=" & CDate(Format(Date, "dd.mm.yyyy"))
ActiveWorkbook.Worksheets("Anlieferung").Range("A1:L" & iRowL).AutoFilter Field:=2, Criteria1:= _
"Mittag"
druckformat = xlLandscape
End If
'Set Bereich = Tabelle1.UsedRange
Set Bereich = Tabelle1.Range("A2", "A" & iRowL)
Bereich.RowHeight = 30
With ActiveSheet
With .PageSetup
.PaperSize = xlPaperA4
.PrintTitleRows = "$1:$1"
.PrintArea = "A1:E" & iRowL
.FitToPagesTall = False
.FitToPagesWide = 1
.Orientation = druckformat
.Zoom = False
End With
ActiveSheet.PrintPreview
End With
Columns("E:E").EntireColumn.Hidden = True
Bereich.RowHeight = 15
Tabelle1.Range("A1").RowHeight = 30
ActiveWorkbook.Worksheets("Anlieferung").ShowAllData
ActiveWorkbook.Worksheets("Anlieferung").Range("A1").AutoFilter Field:=1, Criteria1:= _
">=" & CLng(CDate(Format(Date, "dd.mm.yyyy")))
Application.ScreenUpdating = True
End Sub
Vielen Dank Thomas