VBA-Code optimieren

Sub Doppeleinträge_aus_Spalten_löschen() ScreenUpdating = False Dim r, c As Variant With Range("AP19:AP1018").Select Set r = Selection.Cells For c = r.Cells.Count To 1 Step -1 If Application.CountIf(r, r(c)) 1 Then r(c).Value = "" Next c End With With Range("AQ19:AQ1018").Select Set r = Selection.Cells For c = r.Cells.Count To 1 Step -1 If Application.CountIf(r, r(c)) 1 Then r(c).Value = "" Next c End With With Range("AR19:AR1018").Select Set r = Selection.Cells For c = r.Cells.Count To 1 Step -1 If Application.CountIf(r, r(c)) 1 Then r(c).Value = "" Next c End With With Range("AS19:AS1018").Select Set r = Selection.Cells For c = r.Cells.Count To 1 Step -1 If Application.CountIf(r, r(c)) 1 Then r(c).Value = "" Next c End With With Range("AT19:AT1018").Select Set r = Selection.Cells For c = r.Cells.Count To 1 Step -1 If Application.CountIf(r, r(c)) 1 Then r(c).Value = "" Next c With Range("AU19:AU1018").Select Set r = Selection.Cells For c = r.Cells.Count To 1 Step -1 If Application.CountIf(r, r(c)) 1 Then r(c).Value = "" Next c End With With Range("AV19:AV1018").Select Set r = Selection.Cells For c = r.Cells.Count To 1 Step -1 If Application.CountIf(r, r(c)) 1 Then r(c).Value = "" Next c End With With Range("AW19:AW1018").Select Set r = Selection.Cells For c = r.Cells.Count To 1 Step -1 If Application.CountIf(r, r(c)) 1 Then r(c).Value = "" Next c End With End With Application.CutCopyMode = False Range("O19").Select ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

du arbeitest überflüssigerweise mit SELECT, was den Code langsam macht.

statt


Range("AV19:AV1018").Select
Set r = Selection.Cells

kann man auch gleich direkt schreiben:


Set r = Range("AV19:AV1018")

deklariere Variablen so, wie sie auch verwendet werden und nicht grundsätzlich als Variant

in deinem Beispiel also:


dim r as Range
dim c as Long

du setzt das Prinzip der WITH-Klammer falsch ein

ne With-Klammer wird verwendet, um Schreibarbeit zu sparen, da das im WITH-Teil festgelegte Objekt im folgenden durch einen Punkt ersetzt werden kann. Beispiel:


WITH Range("A1:C10")
.value = "xxx"
.interior.Colorindex = 10
end with

in deinem Code brauchst die WITH-Klammer nicht, da du ja mit Variablen arbeitest.

Range-Schreibweise

alternativ zu der von dir verwendeten RANGE-Schreibweise für einen Zellbereich kann man auch CELLS verwenden , also stelle von:


Range("AP19:AP1018")

kann man auch Schreiben:


Range(Cells(19, 42), Cells(1018, 42))

da hier auch die Spalten durch Zahlen beschrieben werden und so durch Variablen ersetzt werden können, kannst du deinen Code durch ne weitere Schleife für die einzelnen Spalten zwar nicht beschleunigen, aber stark verkürzen, da für jede Spalte ja gleichen Befehle ablaufen.

der Zeitfresser in deinem Code ist die CountIF-Funktion

erschwerden kommt hinzu, daß du immer den vollen Zellbereich von r verwendest.
das ist aber nicht notwendig, da der Zellbereich mit dem Schleifendurchlauf verkleinert werden kann, da der untere Bereich (unterhalb der Zelle r(c) ) ja "bereinigt" ist.
etwas schneller dürfte also folgende Formel sein:


For c = r.Cells.Count To 1 Step -1
If Application.CountIf(Range(r(1), r(c)), r(c))  1 Then r(c).Value = ""
Next c

weil hier nur der notwendige Teil von r in der Prüfung verwendet wird.
weitere Beschleunigungmethoden dürften deinen Kenntnisstand vorerst noch übersteigen, oder sie erfordern eine genauere Kenntnist der Daten.
Beispielsweise ließe sich das ganze beschleunigen, wenn die Daten einzelen sortiert werden könnten, weil dann zum Finden der doppelten nur zwei benachbarte Zellen geprüft werden müssen.
Bei CountIf werden hingegen ALLE Zellen mit dem Wert verglichen, was natürlich deutlich länger dauert.
Gruß, Daniel

Sub Doppeleinträge_aus_Spalten_löschen() Application.ScreenUpdating = False Dim r As Range, c As Range, iCol As Integer, rDel As Range For iCol = 42 To 49 Set r = Range(Cells(19, iCol), Cells(1018, iCol)) For Each c In r If Application.CountIf(Range(r(1), c), c) > 1 Then If rDel Is Nothing Then Set rDel = c Else Set rDel = Union(rDel, c) End If End If Next c Next iCol rDel = "" Application.ScreenUpdating = True End Sub

Sub Doppeleinträge_aus_Spalten_löschen3() Dim row As Long, col As Long Application.ScreenUpdating = False With ThisWorkbook.Worksheets("Tabelle1") 'ANPASSEN ! For col = 42 To 49 For row = 1018 To 20 Step -1 If Application.CountIf(.Range(.Cells(row, col), _ .Cells(19, col)), .Cells(row, col).Value) > 1 Then .Cells(row, col).Value = "" Next row Next col End With Application.ScreenUpdating = True End Sub

Sub Doppeleinträge_aus_Spalten_löschen3A() Dim row As Long, col As Long Application.ScreenUpdating = False With ThisWorkbook.Worksheets("Tabelle1") 'ANPASSEN ! For col = 42 To 49 If Application.WorksheetFunction.CountA(.Range(.Cells(19, col), .Cells(1018, col))) > 0 _ Then For row = 1018 To 20 Step -1 If Not IsEmpty(.Cells(row, col)) Then If Application.CountIf(.Range(.Cells(row, col), _ .Cells(19, col)), .Cells(row, col).Value) > 1 Then .Cells(row, col).Value = "" End If End If Next row End If Next col End With Application.ScreenUpdating = True End Sub

Sub Doppeleinträge_aus_Spalten_löschen_und_Texte_auslesen3A() Dim row As Long, col As Long 'von Gerd L am 05.06.08 Application.ScreenUpdating = False With ThisWorkbook.Worksheets("Tabelle1") 'ANPASSEN ! For col = 42 To 49 If Application.WorksheetFunction.CountA(.Range(.Cells(19, col), .Cells(1018, col))) > 0 _ _ Then For row = 1018 To 20 Step -1 If Not IsEmpty(.Cells(row, col)) Then If Application.CountIf(.Range(.Cells(row, col), _ .Cells(19, col)), .Cells(row, col).Value) > 1 Then .Cells(row, col).Value = "" End If Next row End If Next col End With Dim Arr, Text, i, Maxzl As Long, sp As Long 'von Mac4 (Marc) am 03.06.08 For sp = Columns("AP").Column To Columns("AW").Column Maxzl = Cells(Rows.Count, sp).End(xlUp).row Arr = Range(Cells(1, sp), Cells(Maxzl, sp)) For i = 1 To UBound(Arr) Text = Text & Arr(i, 1) Next i Cells(sp - 6, "BB") = Text Text = "" Next sp Application.ScreenUpdating = True End Sub

Sub a() Dim Arr As Variant, Text As String, i As Long, Maxzl As Long, sp As Long Dim offs As Long offs = 6 For sp = Columns("AP").Column To Columns("AW").Column Maxzl = Cells(Rows.Count, sp).End(xlUp).Row Arr = Range(Cells(1, sp), Cells(Maxzl, sp)) If IsArray(Arr) Then For i = 1 To UBound(Arr) Text = Text & Arr(i, 1) Next i Else Text = Cells(Maxzl, sp) End If If Text = "" Then offs = offs + 1 Else Cells(sp - offs, "BB") = Text End If Text = "" Next sp End Sub

Hallo Konni,
ich habe den Code auf die Zeilen 19 - 1008 eigeschränkt u. die Variable i umbenannt.
Weitergehende Alterativen würdest Du wahrscheinlich nicht verstehen.
Bei der mitgeteilten Fehlermeldung hattest die Variable "i" entweder andernorts bereits deklariert
oder im Code in den DIM-Anwesungen doppelt drin.
Sub b()
Dim Arr As Variant, Text As String, Ind As Long, Maxzl As Long, sp As Long
Dim offs As Long
offs = 6
For sp = Columns("AP").Column To Columns("AW").Column
Maxzl = Application.Min(1008, Cells(Rows.Count, sp).End(xlUp).Row)
If Maxzl < 19 Then Exit For
Arr = Range(Cells(19, sp), Cells(Maxzl, sp))
If IsArray(Arr) Then
For Ind = 1 To UBound(Arr)
Text = Text & Arr(Ind, 1)
Next Ind
Else
Text = Cells(Maxzl, sp)
End If
If Text = "" Then
offs = offs + 1
Else
Cells(sp - offs, "BB") = Text
End If
Text = ""
Next sp
P.S.: Jetzt ungetestet.
Gruß Gerd

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread