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
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
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
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
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.
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