Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1712to1716
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Bildschirm flackern

Bildschirm flackern
28.09.2019 21:39:17
Policonte
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:=" 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:=" 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:=" 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:=" 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

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bildschirm flackern
28.09.2019 23:02:56
Daniel
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
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige