ScreenUpdating False nach Msg Box in Exel 2016

[Newby81]

Hallo, ich habe Mithilfe dieses Forums ein Makro zusammengebastelt um Werte von einer Exel Datei (Arbeitsauftrag) in eine andere zu kopieren (Datenbank). Das läuft auch reibungslos.

Damit es nicht flackert habe ich an den Anfang des Marko den Befehl screenUpdating=False gesetzt und an das Ende entsprechend true. 

Ich habe in das Makro eine kleine Schleife gebaut, mit der If Funktion, in der überprüft wird ob eine bestimmte Nummer aus dem Arbeitsauftrag schon Mal in der Datenbank vorkommt. Wenn sie vorkommt, erscheint eine Msg Box die den User mitteilt, das die Nummer bereits erfasst ist und ihn per ja und nein fragt,o er den Datensatz wirklich erfassen will.

Wenn der User das will und ja sagt, läuft das Makro ganz normal durch. Jetzt haben wir Exel 2016 bekommen und nach dieser Meldung fängt das Bild zu flackern an:( 
Bei Exel2013 passierte dies nicht.... Da lief das Makro flackerfrei durch....
Wird  die Nummer nicht gefunden, kommt auch keine Msg Box und das Makro läuft flackerfrei durch. Ich denke,dass die Msg Box ScreenUpdating wieder auf true setzt, warum auch immer.... Ich habe dann probiert den Wert vor der If Funktion auf ScreenUpdating true zu setzen und danach wieder auf False, leider brachte das nichts....

Hat jemand von euch eine Idee, wo der Fehler liegt?

Dankeschön

Gruß

Torben

[Frogger1986]

Zeig mal deinen code

[Newby81]

Mir ist bewusst, dass ich Anfänger bin und das sicher Verbesserungswürdig ist, aber der Code läuft soweit und mir geht es wirklich in erster Linie
um das Flackern.....Also seid bitte nicht zu hart;)

Mein Code sieht so aus:

Code:

Sub Synchronisieren2()

Dim Quelle As Workbook, WS1 As Worksheet
    Dim daten As Workbook, WS2 As Worksheet
    Dim strZiel As String, strPfadZiel As String
    Dim bolOpen As Boolean
    Dim Zeile_Z As Long, Zelle_Letzte As Range
    
    Set Quelle = ActiveWorkbook 'Datei "Laufkarte_zur_Auftragsabwicklung.xlsm"
    Set WS1 = Quelle.ActiveSheet
    
    Application.ScreenUpdating = False
    
    strPfadZiel = "S:\testbuch.xlsx"       '### anpassen ##!!!
    strZiel = "testbuch.xlsx"
    
    'Fehlermeldung
    
    If fncCheckWorkbookOpen(strZiel) Then
      Set daten = Application.Workbooks(strZiel)
        bolOpen = True
    Else
      bolOpen = False
    End If
    
    If bolOpen = True Then
        
        MsgBox "Datenbank wird gerade genutzt, versuch es gleich nochmal!", vbExclamation
          Set daten = Nothing: Set WS2 = Nothing: Set Zelle_Letzte = Nothing
  Set Quelle = Nothing: Set WS1 = Nothing
  Exit Sub
                   
          If bolOpen = False Then
          Else    
        
        End If
        
   End If
 
  
        Set daten = Workbooks.Open("S:\testbuch.xlsx")
        Set WS2 = daten.Sheets("Mobi Arbeitsbuch")

If WorksheetFunction.CountIf(WS2.Range("E2:E1400"), WS1.Range("c1").Value2) > 0 Then

            If MsgBox("" & WS1.Range("c1") & " wurde bereits einmal erfasst, wirklich nochmal erfassen????", vbYesNo + vbQuestion) = vbNo Then
           daten.Close savechanges:=False
            Exit Sub
            Else: End If           
    End If

    'Daten kopieren
    
    'Ticket
   With WS1
   .Activate
    [C10].Copy
    
        With WS2
        .Activate
        i = Cells(Rows.Count, 2).End(xlUp).Row + 1
        Cells(i, 2).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False     
      
         'Auftragsnummer
        ActiveCell.Offset(0, -1).Range("A1").Select
        Application.CutCopyMode = False
        Selection.Copy
    
              With WS1
              .Activate
                [j6].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                End With
        End With
        
    End With   
               
      'hier kommen jetzt noch einige Kopierbefehle die habe ich jetzt mal weggelassen...
        
         'Bearbeitungsdauer
            i = Cells(Rows.Count, 11).End(xlUp).Row + 0
            Cells(i, 11).Select
            Selection.Copy
            Cells(ActiveCell.Row + 1, 11).Select
            End With
        End With   
     With WS2
        .Activate
        ActiveSheet.Paste
        ActiveWorkbook.Save
        ActiveWindow.Close
            With WS1
            .Activate
            End With
        End With   
                      
'flackern abstellen
Application.ScreenUpdating = True   
   
   If MsgBox("Daten wurden ohne Fehler kopiert!" & vbCrLf & "Datei jetzt Drucken?", vbYesNo) = vbYes Then
        
         Application.Dialogs(xlDialogPrint).Sho        
      Else     
         End If
Set daten = Nothing
Set Quelle = Nothing
Set i = Nothing
ClearClipboard = True
 
 End Sub

Public Function fncCheckWorkbookOpen(ByVal strName As String) As Boolean
 
  Dim wb As Workbook
  On Error GoTo Fehler
  fncCheckWorkbookOpen = True
  Set wb = Application.Workbooks(strName)
Fehler:
  With Err
    Select Case .Number
      Case 0 'Alles ok
      Case Else
       fncCheckWorkbookOpen = False
    End Select
  End With
End Function

[schauan]

Hallöchen,

Mit Deine Withs gehst Du aber auch ganz schön um …

Ich hab hier mal bisschen was korrigiert, allerdings ungetestet und der Code war ja auch nicht vollständig. Wenn Du mit With arbeitest, solltest Du auch konsequent sie Möglichkeiten Nutzen. Meist hast Du ja nur .Activate hinterher genutzt und dann machst Du mit Cells … oder was auch immer auf dem Blatt weiter.  Korrekt wäre, das .Activate wegzulassen und dafür .Cells zu nehmen.

Ebenso solltest Du Sachen, die auch von der Reihenfolge her bei Dir nicht im With stehen müssen, rausnehmen wie Speichern und Schließen.
Wenn Du das End With vom WS2 weiter hoch nimmst, bist Du wieder im With von WS1 und brauchst das nicht nochmal.
Else brauchst Du nicht programmieren, wenn Du da nix drin hast.
Nach mehr hab ich erst mal nicht geschaut

Code:

Option Explicit

Sub Synchronisieren2()
Dim Quelle As Workbook, WS1 As Worksheet
 Dim daten As Workbook, WS2 As Worksheet
 Dim strZiel As String, strPfadZiel As String
 Dim bolOpen As Boolean
 Dim Zeile_Z As Long, Zelle_Letzte As Range
 
 Set Quelle = ActiveWorkbook 'Datei "Laufkarte_zur_Auftragsabwicklung.xlsm"
 Set WS1 = Quelle.ActiveSheet
 
 Application.ScreenUpdating = False
 
 strPfadZiel = "S:\testbuch.xlsx"       '### anpassen ##!!!
 strZiel = "testbuch.xlsx"
 
 'Fehlermeldung
 
 If fncCheckWorkbookOpen(strZiel) Then
   Set daten = Application.Workbooks(strZiel)
   bolOpen = True
 Else
   bolOpen = False
 End If
 
 If bolOpen = True Then
   MsgBox "Datenbank wird gerade genutzt, versuch es gleich nochmal!", vbExclamation
     Set daten = Nothing: Set WS2 = Nothing: Set Zelle_Letzte = Nothing
   Set Quelle = Nothing: Set WS1 = Nothing
   Exit Sub
   
   If bolOpen = False Then
   Else
   End If
     
 End If
 
 Set daten = Workbooks.Open("S:\testbuch.xlsx")
 Set WS2 = daten.Sheets("Mobi Arbeitsbuch")
 If WorksheetFunction.CountIf(WS2.Range("E2:E1400"), WS1.Range("c1").Value2) > 0 Then
   If MsgBox("" & WS1.Range("c1") & " wurde bereits einmal erfasst, wirklich nochmal erfassen????", vbYesNo + vbQuestion) = vbNo Then
     daten.Close savechanges:=False
     Exit Sub
   Else: End If
 End If
 'Daten kopieren
 'Ticket
 With WS1
    .Range("C10").Copy
    With WS2
      i = .Cells(Rows.Count, 2).End(xlUp).Row + 1
      .Cells(i, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
       'Auftragsnummer
      .Cells(i, 2).Offset(0, -1).Range("A1").Copy
    End With
    .Range("j6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
 End With
 
 'hier kommen jetzt noch einige Kopierbefehle die habe ich jetzt mal weggelassen...
 'Deswegen fehlen hier auch ein paar With ...
    'Bearbeitungsdauer
     i = Cells(Rows.Count, 11).End(xlUp).Row + 0
     Cells(i, 11).Select
     Selection.Copy
     Cells(ActiveCell.Row + 1, 11).Select
   End With
 End With
   
 With WS2
   .Activate
   ActiveSheet.Paste
 End With
 
 ActiveWorkbook.Save
 ActiveWindow.Close
 
 With WS1
   .Activate
 End With
                     
 'flackern abstellen
 Application.ScreenUpdating = True
 If MsgBox("Daten wurden ohne Fehler kopiert!" & vbCrLf & "Datei jetzt Drucken?", vbYesNo) = vbYes Then
    Application.Dialogs(xlDialogPrint).Show
 Else
 End If
         
 Set daten = Nothing
 Set Quelle = Nothing
 Set i = Nothing
 ClearClipboard = True

End Sub

[Newby81]

Hallo schauan,

erstmal danke für das Feedback, ich bin nun noch sehr grün hinter den Ohren im VBA Bereich und von daher immer für Tipps dankbar. Ich muss mich noch sehr sehr von dem selektieren lösen und Arbeitsschritte zusammenfassen.... das fällt mir wirklich schwer.....

Ich werde deine Änderungen gleich Montag im Büro Mal umsetzen!

Hast du auch eine Idee, warum unter Exel 2016 jetzt das flackern erfolgt, wenn die Zählschleife einen Treffer hat und man das Makro dennoch ausführen möchte?

Gruß

Torben

[schauan]

Hallo Torben,

erst mal nicht. Excel2016 ist sowieso an manchen Stellen mit dem Bildaufbau sehr seltsam … siehe z.B. meine Frage hier:
https://www.clever-excel-forum.de/thread-20120.html

(Nicht nur) Deswegen wollte ich auch das activate aus Deinem Code rausnehmen.

[Newby81]

Moin, ich wollte nur ne kurze Rückmeldung geben.....

Ich habe den Code jetzt so geändert wie schauan es Vorgeschlagen hat und das Flackern ist besser geworden, es ist immer noch da aber nicht mehr ganz so schlimm wie ursprünglich.....

Vielen Dank  für die Hilfe!

Ich finde es echt super wie das hier funktioniert und toll wie ihr euch die Zeit nehmt !

Gruß

Torben