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