Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Bildschirm flackern


Betrifft: Bildschirm flackern von: Policonte
Geschrieben am: 28.09.2019 21:39:17

Hallo , bei diesem Makro spielt mein Bildschirm verrückt , kann man es irgendwie umschreiben das der Bildschirm ruhig bleibt ?

Sub GfosDatenWLK()
'
' GfosDatenSpritzen Makro

'Einstellungen Statusbar
  
   With UserForm1
   UserForm1.ProgressBar1.Max = 11 'Anzahl der Schritte
   UserForm1.ProgressBar1.Min = 0
   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Min '

 Dim lngCalc As Long
  With Application
    lngCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
'Display best?tigungen ausschalten

   Application.DisplayAlerts = False

'Bildschirmaktualisierung ausschalten:

   Application.ScreenUpdating = False
     
'Datei kumuliert ?ffnen egal was f?r Zus?tze im Dateinamen stehen bezieht sich nur auf  _
kumuliert
   
   lstrDatei = Dir("C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\*Prio WLK*.xls")
   If lstrDatei <> "" Then
   Workbooks.Open ("C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\" & lstrDatei)
   Else
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
        
'Wenn Datei nicht vorhanden Makro abrechen

   MsgBox "Datei nicht vorhanden :-("
   Exit Sub
   End If
    
'L?scht Zeilen 1-3
       
   Rows("1:3").Delete Shift:=xlUp
    
'L?scht nicht ben?tigte Spalten

   Columns("Q:Q").Delete Shift:=xlToLeft
   Columns("P:P").Delete Shift:=xlToLeft
   Columns("N:N").Delete Shift:=xlToLeft
   Columns("L:L").Delete Shift:=xlToLeft
   Columns("K:K").Delete Shift:=xlToLeft
   Columns("J:J").Delete Shift:=xlToLeft
   Columns("I:I").Delete Shift:=xlToLeft
   Columns("F:F").Delete Shift:=xlToLeft
   Columns("D:D").Delete Shift:=xlToLeft
   Columns("B:B").Delete Shift:=xlToLeft
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
 'L?schen der Zeile, wenn Zelle in Spalte A leer ist
         
   Dim introw As Integer, intLastRow As Integer
   intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
   For introw = intLastRow To 1 Step -1
   If Application.CountA(Rows(introw)) = 0 Then
        intLastRow = intLastRow - 1
   Else
   Exit For
   End If
   Next introw
   For introw = intLastRow To 1 Step -1
   If IsEmpty(Cells(introw, 1)) Then
   Rows(introw).Delete
   End If
   Next introw
   
'Spalte A umbennen

   Range("A1").FormulaR1C1 = "Datum"
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
'Filter setzen Mand Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="Mand"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With

'Filter setzen TITA Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="TITA"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Filter setzen Datum / Zeit Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="Datum / Zeit"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
   End With
    
'Text in Spalte B und D

   Columns("B:B").Select
   Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
   Columns("D:D").Select
   Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
   :=Array(1, 1), TrailingMinusNumbers:=True
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
        
 'Filter setzen Produktion Spalte B und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=2, Criteria1:="Produktion"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    

    
'Filter setzen Gemeinkosten Spalte C und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=3, Criteria1:="Gemeinkosten"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Filter setzen Gemeinkosten Spalte B und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=2, Criteria1:="Gemeinkosten"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Filter setzen Gemeinkosten Spalte G und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=7, Criteria1:="0"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Filter setzetn TI06 Spalte F und in neues Tabellenblatt kopieren
    
    With ActiveSheet
    .Range("A1").AutoFilter Field:=6, Criteria1:="TI06"
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
    
    'Filter setzen gr??er als 90000000  Spalte D und l?schen
               
   With ActiveSheet
   .Range("A1").AutoFilter Field:=4, Criteria1:="<90000000"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
   End With
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1

'Filter absteigent sotieren
       
   With ActiveSheet
   .Range("A1").AutoFilter Field:=6
   Range("F" & Range("F65536").End(xlUp).Row).Sort _
   Key1:=Range("F2"), Order1:=xlDescending, Header:= _
   xlGuess, OrderCustom:=1, MatchCase:=False, _
   Orientation:=xlTopToBottom, _
   DataOption1:=xlSortNormal
   .AutoFilterMode = False
   End With

 'Duplicate entfernen
   For i = Range("B65536").End(xlUp).Row To 2 Step -1
   If Application.WorksheetFunction.CountIf(Range("B:B"), Cells(i, 2)) > 1 Then Rows(i). _
   Delete
   Next i
         
'Spalte A kopieren und in B einf?gen

   Columns("A:A").Select
   Selection.Copy
   Columns("H:H").Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
  
'L?scht nicht ben?tigte Spalten

   Columns("A:A").Delete Shift:=xlToLeft
    
'Bereich direkt kopieren
        
   Range("A2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Range(Selection, Selection.End(xlToRight)).Select
   Selection.Copy
    
'Wechsel zu Datei Laufkartenprogramm
   Windows("Laufkartenprogramm Al 3.2.xlsm").Activate
   Sheets("GfosDatenWLK").Select
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
            
'Erste freie Zeiel in A finden und einf?gen
  
   Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteAll
   Application.CutCopyMode = False


'Date schlie?en ohne zu speichern und l?schen

   Workbooks(lstrDatei).Close savechanges:=False
   Kill "C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\" & lstrDatei

    
'Duplicate entfernen

   For i = Range("B65536").End(xlUp).Row To 2 Step -1
   If Application.WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Rows(i). _
   Delete
   Next i
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Gehe f?r n?chste Abfrage auf A1
           
   Range("A1").Select
   
'Datum der aktualisierung einf?gen

   Sheets("LaufkartenProgramm Alu").Range("I1").Value = Date & "/" & Time
   
'Tabellenblatt wechseln

   Sheets("
Sub GfosDatenWLK()
'
' GfosDatenSpritzen Makro

'Einstellungen Statusbar
  
   With UserForm1
   UserForm1.ProgressBar1.Max = 11 'Anzahl der Schritte
   UserForm1.ProgressBar1.Min = 0
   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Min '

 Dim lngCalc As Long
  With Application
    lngCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
'Display best?tigungen ausschalten

   Application.DisplayAlerts = False

'Bildschirmaktualisierung ausschalten:

   Application.ScreenUpdating = False
     
'Datei kumuliert ?ffnen egal was f?r Zus?tze im Dateinamen stehen bezieht sich nur auf  _
kumuliert
   
   lstrDatei = Dir("C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\*Prio WLK*.xls")
   If lstrDatei <> "" Then
   Workbooks.Open ("C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\" & lstrDatei)
   Else
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
        
'Wenn Datei nicht vorhanden Makro abrechen

   MsgBox "Datei nicht vorhanden :-("
   Exit Sub
   End If
    
'L?scht Zeilen 1-3
       
   Rows("1:3").Delete Shift:=xlUp
    
'L?scht nicht ben?tigte Spalten

   Columns("Q:Q").Delete Shift:=xlToLeft
   Columns("P:P").Delete Shift:=xlToLeft
   Columns("N:N").Delete Shift:=xlToLeft
   Columns("L:L").Delete Shift:=xlToLeft
   Columns("K:K").Delete Shift:=xlToLeft
   Columns("J:J").Delete Shift:=xlToLeft
   Columns("I:I").Delete Shift:=xlToLeft
   Columns("F:F").Delete Shift:=xlToLeft
   Columns("D:D").Delete Shift:=xlToLeft
   Columns("B:B").Delete Shift:=xlToLeft
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
 'L?schen der Zeile, wenn Zelle in Spalte A leer ist
         
   Dim introw As Integer, intLastRow As Integer
   intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
   For introw = intLastRow To 1 Step -1
   If Application.CountA(Rows(introw)) = 0 Then
        intLastRow = intLastRow - 1
   Else
   Exit For
   End If
   Next introw
   For introw = intLastRow To 1 Step -1
   If IsEmpty(Cells(introw, 1)) Then
   Rows(introw).Delete
   End If
   Next introw
   
'Spalte A umbennen

   Range("A1").FormulaR1C1 = "Datum"
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
'Filter setzen Mand Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="Mand"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With

'Filter setzen TITA Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="TITA"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Filter setzen Datum / Zeit Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="Datum / Zeit"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
   End With
    
'Text in Spalte B und D

   Columns("B:B").Select
   Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
   Columns("D:D").Select
   Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
   :=Array(1, 1), TrailingMinusNumbers:=True
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
        
 'Filter setzen Produktion Spalte B und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=2, Criteria1:="Produktion"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    

    
'Filter setzen Gemeinkosten Spalte C und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=3, Criteria1:="Gemeinkosten"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Filter setzen Gemeinkosten Spalte B und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=2, Criteria1:="Gemeinkosten"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Filter setzen Gemeinkosten Spalte G und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=7, Criteria1:="0"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Filter setzetn TI06 Spalte F und in neues Tabellenblatt kopieren
    
    With ActiveSheet
    .Range("A1").AutoFilter Field:=6, Criteria1:="TI06"
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
    
    'Filter setzen gr??er als 90000000  Spalte D und l?schen
               
   With ActiveSheet
   .Range("A1").AutoFilter Field:=4, Criteria1:="<90000000"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
   End With
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1

'Filter absteigent sotieren
       
   With ActiveSheet
   .Range("A1").AutoFilter Field:=6
   Range("F" & Range("F65536").End(xlUp).Row).Sort _
   Key1:=Range("F2"), Order1:=xlDescending, Header:= _
   xlGuess, OrderCustom:=1, MatchCase:=False, _
   Orientation:=xlTopToBottom, _
   DataOption1:=xlSortNormal
   .AutoFilterMode = False
   End With

 'Duplicate entfernen
   For i = Range("B65536").End(xlUp).Row To 2 Step -1
   If Application.WorksheetFunction.CountIf(Range("B:B"), Cells(i, 2)) > 1 Then Rows(i). _
   Delete
   Next i
         
'Spalte A kopieren und in B einf?gen

   Columns("A:A").Select
   Selection.Copy
   Columns("H:H").Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
  
'L?scht nicht ben?tigte Spalten

   Columns("A:A").Delete Shift:=xlToLeft
    
'Bereich direkt kopieren
        
   Range("A2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Range(Selection, Selection.End(xlToRight)).Select
   Selection.Copy
    
'Wechsel zu Datei Laufkartenprogramm
   Windows("Laufkartenprogramm Al 3.2.xlsm").Activate
   Sheets("GfosDatenWLK").Select
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
            
'Erste freie Zeiel in A finden und einf?gen
  
   Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteAll
   Application.CutCopyMode = False


'Date schlie?en ohne zu speichern und l?schen

   Workbooks(lstrDatei).Close savechanges:=False
   Kill "C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\" & lstrDatei

    
'Duplicate entfernen

   For i = Range("B65536").End(xlUp).Row To 2 Step -1
   If Application.WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Rows(i). _
   Delete
   Next i
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Gehe f?r n?chste Abfrage auf A1
           
   Range("A1").Select
   
'Datum der aktualisierung einf?gen

   Sheets("LaufkartenProgramm Alu").Range("I1").Value = Date & "/" & Time
   
'Tabellenblatt wechseln

   Sheets("
Sub GfosDatenWLK()
'
' GfosDatenSpritzen Makro

'Einstellungen Statusbar
  
   With UserForm1
   UserForm1.ProgressBar1.Max = 11 'Anzahl der Schritte
   UserForm1.ProgressBar1.Min = 0
   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Min '

 Dim lngCalc As Long
  With Application
    lngCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
'Display best?tigungen ausschalten

   Application.DisplayAlerts = False

'Bildschirmaktualisierung ausschalten:

   Application.ScreenUpdating = False
     
'Datei kumuliert ?ffnen egal was f?r Zus?tze im Dateinamen stehen bezieht sich nur auf  _
kumuliert
   
   lstrDatei = Dir("C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\*Prio WLK*.xls")
   If lstrDatei <> "" Then
   Workbooks.Open ("C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\" & lstrDatei)
   Else
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
        
'Wenn Datei nicht vorhanden Makro abrechen

   MsgBox "Datei nicht vorhanden :-("
   Exit Sub
   End If
    
'L?scht Zeilen 1-3
       
   Rows("1:3").Delete Shift:=xlUp
    
'L?scht nicht ben?tigte Spalten

   Columns("Q:Q").Delete Shift:=xlToLeft
   Columns("P:P").Delete Shift:=xlToLeft
   Columns("N:N").Delete Shift:=xlToLeft
   Columns("L:L").Delete Shift:=xlToLeft
   Columns("K:K").Delete Shift:=xlToLeft
   Columns("J:J").Delete Shift:=xlToLeft
   Columns("I:I").Delete Shift:=xlToLeft
   Columns("F:F").Delete Shift:=xlToLeft
   Columns("D:D").Delete Shift:=xlToLeft
   Columns("B:B").Delete Shift:=xlToLeft
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
 'L?schen der Zeile, wenn Zelle in Spalte A leer ist
         
   Dim introw As Integer, intLastRow As Integer
   intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
   For introw = intLastRow To 1 Step -1
   If Application.CountA(Rows(introw)) = 0 Then
        intLastRow = intLastRow - 1
   Else
   Exit For
   End If
   Next introw
   For introw = intLastRow To 1 Step -1
   If IsEmpty(Cells(introw, 1)) Then
   Rows(introw).Delete
   End If
   Next introw
   
'Spalte A umbennen

   Range("A1").FormulaR1C1 = "Datum"
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
'Filter setzen Mand Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="Mand"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With

'Filter setzen TITA Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="TITA"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Filter setzen Datum / Zeit Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="Datum / Zeit"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
   End With
    
'Text in Spalte B und D

   Columns("B:B").Select
   Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
   Columns("D:D").Select
   Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
   :=Array(1, 1), TrailingMinusNumbers:=True
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
        
 'Filter setzen Produktion Spalte B und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=2, Criteria1:="Produktion"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    

    
'Filter setzen Gemeinkosten Spalte C und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=3, Criteria1:="Gemeinkosten"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Filter setzen Gemeinkosten Spalte B und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=2, Criteria1:="Gemeinkosten"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Filter setzen Gemeinkosten Spalte G und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=7, Criteria1:="0"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Filter setzetn TI06 Spalte F und in neues Tabellenblatt kopieren
    
    With ActiveSheet
    .Range("A1").AutoFilter Field:=6, Criteria1:="TI06"
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
    
    'Filter setzen gr??er als 90000000  Spalte D und l?schen
               
   With ActiveSheet
   .Range("A1").AutoFilter Field:=4, Criteria1:="<90000000"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
   End With
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1

'Filter absteigent sotieren
       
   With ActiveSheet
   .Range("A1").AutoFilter Field:=6
   Range("F" & Range("F65536").End(xlUp).Row).Sort _
   Key1:=Range("F2"), Order1:=xlDescending, Header:= _
   xlGuess, OrderCustom:=1, MatchCase:=False, _
   Orientation:=xlTopToBottom, _
   DataOption1:=xlSortNormal
   .AutoFilterMode = False
   End With

 'Duplicate entfernen
   For i = Range("B65536").End(xlUp).Row To 2 Step -1
   If Application.WorksheetFunction.CountIf(Range("B:B"), Cells(i, 2)) > 1 Then Rows(i). _
   Delete
   Next i
         
'Spalte A kopieren und in B einf?gen

   Columns("A:A").Select
   Selection.Copy
   Columns("H:H").Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
  
'L?scht nicht ben?tigte Spalten

   Columns("A:A").Delete Shift:=xlToLeft
    
'Bereich direkt kopieren
        
   Range("A2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Range(Selection, Selection.End(xlToRight)).Select
   Selection.Copy
    
'Wechsel zu Datei Laufkartenprogramm
   Windows("Datenjlk").Activate
   Sheets("GfosDatenWLK").Select
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
            
'Erste freie Zeiel in A finden und einf?gen
  
   Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteAll
   Application.CutCopyMode = False


'Date schlie?en ohne zu speichern und l?schen

   Workbooks(lstrDatei).Close savechanges:=False
   Kill "C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\" & lstrDatei

    
'Duplicate entfernen

   For i = Range("B65536").End(xlUp).Row To 2 Step -1
   If Application.WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Rows(i). _
   Delete
   Next i
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Gehe f?r n?chste Abfrage auf A1
           
   Range("A1").Select
   
'Datum der aktualisierung einf?gen

   Sheets("Datenjlk").Range("I1").Value = Date & "/" & Time
   
'Tabellenblatt wechseln

   Sheets("
Sub GfosDatenWLK()
'
' GfosDatenSpritzen Makro

'Einstellungen Statusbar
  
   With UserForm1
   UserForm1.ProgressBar1.Max = 11 'Anzahl der Schritte
   UserForm1.ProgressBar1.Min = 0
   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Min '

 Dim lngCalc As Long
  With Application
    lngCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
'Display best?tigungen ausschalten

   Application.DisplayAlerts = False

'Bildschirmaktualisierung ausschalten:

   Application.ScreenUpdating = False
     
'Datei kumuliert ?ffnen egal was f?r Zus?tze im Dateinamen stehen bezieht sich nur auf  _
kumuliert
   
   lstrDatei = Dir("C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\*Prio WLK*.xls")
   If lstrDatei <> "" Then
   Workbooks.Open ("C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\" & lstrDatei)
   Else
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
        
'Wenn Datei nicht vorhanden Makro abrechen

   MsgBox "Datei nicht vorhanden :-("
   Exit Sub
   End If
    
'L?scht Zeilen 1-3
       
   Rows("1:3").Delete Shift:=xlUp
    
'L?scht nicht ben?tigte Spalten

   Columns("Q:Q").Delete Shift:=xlToLeft
   Columns("P:P").Delete Shift:=xlToLeft
   Columns("N:N").Delete Shift:=xlToLeft
   Columns("L:L").Delete Shift:=xlToLeft
   Columns("K:K").Delete Shift:=xlToLeft
   Columns("J:J").Delete Shift:=xlToLeft
   Columns("I:I").Delete Shift:=xlToLeft
   Columns("F:F").Delete Shift:=xlToLeft
   Columns("D:D").Delete Shift:=xlToLeft
   Columns("B:B").Delete Shift:=xlToLeft
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
 'L?schen der Zeile, wenn Zelle in Spalte A leer ist
         
   Dim introw As Integer, intLastRow As Integer
   intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
   For introw = intLastRow To 1 Step -1
   If Application.CountA(Rows(introw)) = 0 Then
        intLastRow = intLastRow - 1
   Else
   Exit For
   End If
   Next introw
   For introw = intLastRow To 1 Step -1
   If IsEmpty(Cells(introw, 1)) Then
   Rows(introw).Delete
   End If
   Next introw
   
'Spalte A umbennen

   Range("A1").FormulaR1C1 = "Datum"
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
'Filter setzen Mand Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="Mand"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With

'Filter setzen TITA Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="TITA"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Filter setzen Datum / Zeit Spalte A und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=1, Criteria1:="Datum / Zeit"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
   End With
    
'Text in Spalte B und D

   Columns("B:B").Select
   Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
   Columns("D:D").Select
   Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
   :=Array(1, 1), TrailingMinusNumbers:=True
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
        
 'Filter setzen Produktion Spalte B und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=2, Criteria1:="Produktion"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    

    
'Filter setzen Gemeinkosten Spalte C und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=3, Criteria1:="Gemeinkosten"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Filter setzen Gemeinkosten Spalte B und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=2, Criteria1:="Gemeinkosten"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Filter setzen Gemeinkosten Spalte G und l?schen
 
   With ActiveSheet
   .Range("A1").AutoFilter Field:=7, Criteria1:="0"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
    End With
    
'Filter setzetn TI06 Spalte F und in neues Tabellenblatt kopieren
    
    With ActiveSheet
    .Range("A1").AutoFilter Field:=6, Criteria1:="TI06"
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End With
    
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
    
    'Filter setzen gr??er als 90000000  Spalte D und l?schen
               
   With ActiveSheet
   .Range("A1").AutoFilter Field:=4, Criteria1:="<90000000"
   .Rows(1).Hidden = True
   .UsedRange.SpecialCells(xlCellTypeVisible).Delete
   .Rows(1).Hidden = False
   .AutoFilterMode = False
   End With
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1

'Filter absteigent sotieren
       
   With ActiveSheet
   .Range("A1").AutoFilter Field:=6
   Range("F" & Range("F65536").End(xlUp).Row).Sort _
   Key1:=Range("F2"), Order1:=xlDescending, Header:= _
   xlGuess, OrderCustom:=1, MatchCase:=False, _
   Orientation:=xlTopToBottom, _
   DataOption1:=xlSortNormal
   .AutoFilterMode = False
   End With

 'Duplicate entfernen
   For i = Range("B65536").End(xlUp).Row To 2 Step -1
   If Application.WorksheetFunction.CountIf(Range("B:B"), Cells(i, 2)) > 1 Then Rows(i). _
   Delete
   Next i
         
'Spalte A kopieren und in B einf?gen

   Columns("A:A").Select
   Selection.Copy
   Columns("H:H").Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
  
'L?scht nicht ben?tigte Spalten

   Columns("A:A").Delete Shift:=xlToLeft
    
'Bereich direkt kopieren
        
   Range("A2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Range(Selection, Selection.End(xlToRight)).Select
   Selection.Copy
    
'Wechsel zu Datei Laufkartenprogramm
   Windows("Laufkartenprogramm Al 3.2.xlsm").Activate
   Sheets("GfosDatenWLK").Select
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
            
'Erste freie Zeiel in A finden und einf?gen
  
   Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteAll
   Application.CutCopyMode = False


'Date schlie?en ohne zu speichern und l?schen

   Workbooks(lstrDatei).Close savechanges:=False
   Kill "C:\Users\OliS\Desktop\Daten\Alle Daten Wachs\" & lstrDatei

    
'Duplicate entfernen

   For i = Range("B65536").End(xlUp).Row To 2 Step -1
   If Application.WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Rows(i). _
   Delete
   Next i
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
    
'Gehe f?r n?chste Abfrage auf A1
           
   Range("A1").Select
   
'Datum der aktualisierung einf?gen

   Sheets("Datenjlk").Range("I1").Value = Date & "/" & Time
   
'Tabellenblatt wechseln

   Sheets("Datenjlk").Select
   
'Statusbar f?llen

   UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1
   
'Excelbildschrim ausblenden
  
   Application.Visible = False
    
'Anzeige MsgBox

   MsgBox "Aktualisierung erfolgreich"
   
'Statusbar auf Null setzen
   
   UserForm1.ProgressBar1.Value = 0
     Application.Calculation = lngCalc
      

    
   
End With
End With

End Sub






").Select

'Statusbar f?llen

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1

'Excelbildschrim ausblenden

Application.Visible = False

'Anzeige MsgBox

MsgBox "Aktualisierung erfolgreich"

'Statusbar auf Null setzen

UserForm1.ProgressBar1.Value = 0
Application.Calculation = lngCalc




End With
End With

End Sub






").Select

'Statusbar f?llen

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1

'Excelbildschrim ausblenden

Application.Visible = False

'Anzeige MsgBox

MsgBox "Aktualisierung erfolgreich"

'Statusbar auf Null setzen

UserForm1.ProgressBar1.Value = 0
Application.Calculation = lngCalc




End With
End With

End Sub






").Select

'Statusbar f?llen

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1 'f?llt den Balken um 1

'Excelbildschrim ausblenden

Application.Visible = False

'Anzeige MsgBox

MsgBox "Aktualisierung erfolgreich"

'Statusbar auf Null setzen

UserForm1.ProgressBar1.Value = 0
Application.Calculation = lngCalc




End With
End With

End Sub






  

Betrifft: AW: Bildschirm flackern von: Daniel
Geschrieben am: 28.09.2019 23:02:56

Hi
drück den Knopf der sich bei den meisten Bildschirmen in der rechten unteren Ecke befindet nach start des Makros und ein zweites mal, wenn das Makro durchgelaufen sein sollte.

sorry, ne im ernst, bei dem Umfang der Rahmen der kostenlosen Nachbarschaftshilfe etwas überschritten.
(imt Leezeilen sind das hier über 1000 Zeilen Code!)

wenn du ein paar Tipps brauchst:
1. die hier beschriebenen Anregungen konsequent umsetzen:
https://www.online-excel.de/excel/singsel_vba.php?f=78
(ohne Select und Activate arbeiten)

2. verzichte auf die Progressbar und lass den Rechner in ruhe arbeiten.
dann schaltest du einmal am Anfang die Bildschirmakualisierung aus und lässt den Bildschirm einfrieren, bis das Makro durchgelaufen ist.

3. das Application.ScreenUpdating = False sollte einmal am Anfang kommen.
verzichte auf Application.ScreenUpdating = True im Code. Excel schaltet die Bildschirmaktualisierung automatisch wieder ein, wenn der Code durchgelaufen ist.
Du verhinderst damit, dass die Bildschirmaktualisierung versehentlich eingeschaltet wird, wenn das ganze in einem mehrfach aufgerufenen untermakro passiert.

Gruß Daniel


Beiträge aus dem Excel-Forum zum Thema "Bildschirm flackern"