ScreenUpdating
12.03.2016 21:01:55
Benedikt
Guten Abend zusammen
Vielleicht kann mir jemand helfen
Wird nachfolgender Code ausgeführt, blendet sich trotz ScreenUpdating = false
die Zielarbeitsmappe ein. Der Code läuft sonst fehlerfrei, aber das sichtbar machen der Arbeitsmappe ist nicht wirklich das wahre.
Leider ist das nur mit 2013 der Fall, 2010 läuft ohne Probleme durch
Was für Möglichkeiten gibt es oder ist ein Fehler im Code?
Vielen Dank für eure Hilfe
Sub Test()
Dim wkb As Workbook
Dim wksOfferte As Worksheet, wksTitle As Worksheet
Dim iRowT As Integer
Dim i As Integer 'Anzahl der Quellzellen
On Error GoTo ERRORHANDLER
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wkb = Workbooks("Tempoff.xlsm")
Set wksOfferte = wkb.Worksheets("Offerte")
Set wksTitle = wkb.Worksheets("Titel")
iRowT = wksOfferte.Cells(wksOfferte.Rows.Count, 3).End(xlUp).Row + 2
If iRowT < 21 Then iRowT = 21
iRowT = iRowT + 1
wksOfferte.Range("B" & iRowT & ":K1000").Font.Bold = False
'Titel kopieren
wksOfferte.Cells(iRowT, 3).Value = Range("C8").Value
wksOfferte.Cells(iRowT, 3).Font.Bold = True
'Nummerierung
wksOfferte.Cells(iRowT, 2).Value = Int(WorksheetFunction.Max(wksOfferte.Columns(2)) + 1)
'Abstand zu letzter beschriebener Zelle
iRowT = iRowT + 2
'Textblock kopieren
i = ActiveSheet.Range("C9:C21").Cells.Count
wksOfferte.Cells(iRowT, 3).Resize(i, 1).Value = ActiveSheet.Range("C9:C21").Value
'Letzte beschriebene Zeile suchen
iRowT = wksOfferte.Cells(wksOfferte.Rows.Count, 3).End(xlUp).Row
'Anzahl, Einheit und Preis kopieren
i = ActiveSheet.Range("I8:K8").Cells.Count
wksOfferte.Cells(iRowT, 8).Resize(, 3).Value = ActiveSheet.Range("I8:K8").Value
'Übergabe Auswertung an Titelblatt
i = ActiveSheet.Range("O4:AC4").Cells.Count
wksTitle.Cells(26, 1).Resize(, 13).Value = ActiveSheet.Range("O4:AC4").Value
wksTitle.Rows(26).Insert
With wksTitle.Range("A27:M27").Font
.Name = "Arial"
.Size = 8
End With
With wksTitle.Range("C27:M27")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.NumberFormat = "0.00"
End With
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Hier wird die Arbeitsmappe Offerte kurz eingeblendet
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Arbeitsblatt in Arbeitsmappe Offerte kopieren
ActiveSheet.Copy After:=wkb.Worksheets(3)
ActiveSheet.Name = wkb.Worksheets.Count + 1 & " " & Left(Range("C8").Value, 15)
ActiveWorkbook.BreakLink Name:="C:\Hugo 2020\Tempkalk.xlsm", Type:=xlExcelLinks
wksOfferte.Activate
ActiveWorkbook.Save
ThisWorkbook.Activate
'Arbeitsblatt drucken
ActiveSheet.PrintOut Copies:=1
MsgBox "Kalkulation I.O "
ERRORHANDLER:
If Err > 0 Then MsgBox Err & ": " & Error
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub