AW: Duplikate mit hilfe einer Makro Schleife löschen
19.12.2013 14:35:26
UweD
Hallo
es hat lange gedauert, aber ich meine ich hab es jetzt.
1)
Ich hab mich nur auf meinen Teil konzentriert.
----------------------------------------------------
Option Explicit
Sub Refresh_Data()
'Aktualisierung der Pivot Tabelle "Simos 18 Pcs."
On Error GoTo Fehler
Dim Erster As Date
Dim SP%, ZE&, LR&
Dim i&
Dim stCalc&
With Application
.ScreenUpdating = False
stCalc = .Calculation
.Calculation = xlCalculationManual
End With
Sheets("External Data").Select
Range("B22").Select
'Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Sheets("External Data").Activate
Range("B23, E23").Select
Do Until IsEmpty(ActiveCell)
If ActiveCell.Offset(1, 0).Value = ActiveCell.Value Then
ActiveCell.Offset(1, 0).EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
Range("B23:B5000,E23:E5000,I23:I5000,K23:K5000").Select
Range("K23").Activate
Selection.Copy
Sheets("1. Cache").Select
Cells(65000, 2).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWorkbook.Worksheets("1. Cache").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("1. Cache").AutoFilter.Sort.SortFields.Add Key:= _
Range("C3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("1. Cache").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'- - - - UweD
SP = 2 'Spalte mit Daten
ZE = 4 'Erste Zeile mit Daten
With ActiveSheet
LR = .Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
Erster = CDate(.Cells(ZE, SP + 1))
For i = ZE + 1 To LR
If .Cells(i, SP) = .Cells(i - 1, SP) Then
If CDate(.Cells(i, SP + 1).Value) = LR Then GoTo Weiter
Else
Erster = CDate(.Cells(i, SP + 1).Value)
End If
Next
End With
Weiter:
'- - - - UweD
'alle Spalten von B bis G "1.Cache" nach "Main Memory" kopieren
Range("B4:G50000").Select
Range("G4").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Main Memory").Select
Cells(65000, 2).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("$B$3:$H$20000").AutoFilter Field:=7, Criteria1:=Array( _
"Abt. 137 FT Analyse", "Auflegen", "Auflegen AEMI NTF loeschen", "freischalten", _
"FT Analyse", "Handling", "PDI pruefen", "="), Operator:=xlFilterValues
Range("B4:E20000").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("LEO DB").Select
Range("B16").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Main Memory").Select
ActiveSheet.Range("$B$3:$H$20000").AutoFilter Field:=7
Sheets("LEO DB").Select
Range("L16:N20000").Select
Application.CutCopyMode = False
Selection.Copy
Range("F16").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Analysis Statistic").Select
Err.Clear
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
With Application
.ScreenUpdating = True
.Calculation = stCalc
End With
End Sub
----------------------------------------------------
einige Ursachen waren.
- du verwendest Spalte ab B und nicht ab A
- du hast meinen Teil in ein Anderes eingebaut.
die Sprungstelle "Exit Sub" funktionierte damit nicht und hab ich geändert
If i >= LR Then GoTo Weiter
- Datum lag als Text vor (übersetze ich nun in ein richtiges Datum)
- .....
----------------------------------------------------
2)
- Ausstellen der automatischen Calkulation bei jeder Zelländerung bringt auch einiges an Zeitgewinn
(wird zum Schluss wieder auf die ursprüngliche Einstellung zurückgesetzt)
--------------------------------------------------
3)
- Du verwendest in deinem Teil sehr oft .select und .activate
- Das kann in den meisten Fällen wegfallen.
>> Wenn du für weitere Operationen nicht tatsächlich in einem bestimmten Blatt in einer Zelle stehen musst, um eine Aktion auszulösen
- auch in dem anderen Modul
Aus:
Range("B23:B5000,E23:E5000,I23:I5000,K23:K5000").Select
Range("K23").Activate
Selection.Copy
kann z.B. werden:
Range("B23:B5000,E23:E5000,I23:I5000,K23:K5000").Copy
dadurch wird der Ablauf ebenfalls viel schneller
----------------------------------------------------
Ich hoffe ich konnte dir helfen
Gruß und Frohes Fest