Schleife beschleunigen

Sub test() Dim letzteZeile As Long Dim DZähler As Long Dim Zähler As Long letzteZeile = Cells(Rows.Count, 1).End(xlUp).Rows.Row For a = 2 To letzteZeile If Cells(a, 1).Value = "201603" And Cells(a, 8).Value = "A" And Cells(a, 14).Value 0 And _ Cells(a, 16).Value = 0 Then Zähler = Zähler + 1 End If If Cells(a, 1).Value = "201603" And Cells(a, 8).Value = "A" And Cells(a, 14).Value 0 And _ Cells(a, 16).Value = 0 And _ Application.WorksheetFunction.CountIf(Range(Cells(a, 5), Cells(letzteZeile, 5)), Cells(a, 5) _ .Value) > 1 Then DZähler = DZähler + 1 End If Next a If Application.WorksheetFunction.CountIfs(Range(Cells(2, 1), Cells(letzteZeile, 1)), "201603", _ Range(Cells(2, 8), Cells(letzteZeile, 8)) _ , "A", Range(Cells(2, 14), Cells(letzteZeile, 14)), "0", Range(Cells(2, 16), Cells( _ letzteZeile, 16)), 0) = Zähler Then MsgBox "es gib " & Zähler & " kunden mit einer eins" Else MsgBox "es gib " & Zähler - DZähler & " kunden mit einer eins" End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub Find_Methode() Dim WkSh_1 As Worksheet Dim WkSh_2 As Worksheet Dim lZeile As Long Dim rZelle As Range Dim sFundst As String Dim sSuchbegriff As String sSuchbegriff = "j" If sSuchbegriff "" Then Application.ScreenUpdating = False Application.EnableEvents = False 'Set WkSh_1 = ThisWorkbook.Worksheets("Sicherung_Telefonliste") Set WkSh_2 = ThisWorkbook.Worksheets("Telefonliste") With WkSh_2.Columns(1) 'Set Rafound1 = Columns(1).Find("Erledigt", Range("A" & Rows.Count), xlFormulas, _ ' xlWhole, , xlNext) Set rZelle = .Find(sSuchbegriff, .Count, xlFormulas, xlWhole, xlValues) If Not rZelle Is Nothing Then sFundst = rZelle.Address Do ' deine Aktionen mit rZelle.Offset(0,1) ' lZeile = WkSh_1.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' WkSh_2.Range("A" & rZelle.Row & ":H" & rZelle.Row).Copy ' WkSh_1.Range("A" & lZeile & ":H" & lZeile).PasteSpecial Paste:=xlValues ' WkSh_2.Range("A" & rZelle.Row & ":H" & rZelle.Row).Delete Shift:=xlUp Set rZelle = .FindNext(rZelle) Loop While Not rZelle Is Nothing And rZelle.Address sFundst End If End With Application.EnableEvents = True Application.CutCopyMode = False 'Zwischenspeicher löschen Application.ScreenUpdating = True Set WkSh_1 = Nothing 'Set WkSh_2 = Nothing Set rZelle = Nothing End If End Sub

sub test() dim rng as range with columns("A") set rng .find("201603" ) if not rng is nothing then if rng.offset(0,8) = 8 and rng.offset(0,14) 0 and rng.offset(0,16) = 0 then Zaehler = _ Zaehler + 1 end with end sub

Hallo,
teste mal:

Option Explicit

Sub test()

    Dim avntValues As Variant
    Dim letzteZeile As Long
    Dim DZähler As Long
    Dim Zähler As Long
    Dim a As Long

    letzteZeile = Cells(Rows.Count, 1).End(xlUp).Row

    avntValues = Range(Cells(1, 1), Cells(letzteZeile, 16)).Value

    For a = 2 To letzteZeile
        If avntValues(a, 1) = "201603" Then
            If avntValues(a, 8) = "A" Then
                If avntValues(a, 14) <> 0 Then
                    If avntValues(a, 16) = 0 Then
                        Zähler = Zähler + 1
                        If Application.WorksheetFunction.CountIf(Range(Cells(a, 5), _
                            Cells(letzteZeile, 5)), Cells(a, 5).Value) > 1 Then DZähler = DZähler + 1
                    End If
                End If
            End If
        End If
    Next a

    If Application.WorksheetFunction.CountIfs(Range(Cells(2, 1), Cells(letzteZeile, 1)), "201603", _
        Range(Cells(2, 8), Cells(letzteZeile, 8)) _
        , "A", Range(Cells(2, 14), Cells(letzteZeile, 14)), "<>0", Range(Cells(2, 16), Cells( _
        letzteZeile, 16)), 0) = Zähler Then
        MsgBox "es gib " & Zähler & " kunden mit einer eins"
    Else
        MsgBox "es gib " & Zähler - DZähler & " kunden mit einer eins"
    End If

End Sub

Gruß
Nepumuk

Hallo zusammen,
den Verbesserungsvorschlag von Nepumuk habe ich mir zu Herzen genommen und entsprechend angepasst.


Option Explicit
Sub test()
Dim avntValues As Variant
Dim letzteZeile As Long
Dim DZähler As Long
Dim Zähler As Long
Dim a As Long
letzteZeile = Cells(Rows.Count, 1).End(xlUp).Row
avntValues = Range(Cells(1, 1), Cells(letzteZeile, 16)).Value
For a = 2 To letzteZeile
If avntValues(a, 1) = "201603" Then
If avntValues(a, 8) = "A" Then
If avntValues(a, 14)  0 Then
If avntValues(a, 16) = 0 Then
Zähler = Zähler + 1
If Application.WorksheetFunction.CountIf(Range(Cells(a, 5), _
Cells(letzteZeile, 5)), Cells(a, 5).Value) > 1 Then DZähler = DZä _
hler + 1
End If
End If
End If
End If
Next a
If Application.WorksheetFunction.CountIfs(Range(Cells(2, 1), Cells(letzteZeile, 1)), " _
201603", _
Range(Cells(2, 8), Cells(letzteZeile, 8)) _
, "A", Range(Cells(2, 14), Cells(letzteZeile, 14)), "0", Range(Cells(2, 16), Cells( _
letzteZeile, 16)), 0) = Zähler Then
MsgBox "es gib " & Zähler & " kunden mit einer eins"
Else
MsgBox "es gib " & Zähler - DZähler & " kunden mit einer eins"
End If
End Sub

Die Schleife ist jetzt auch viel, viel schneller als vorher. Dafür vielen Dank nochmals.
Jedoch bin ich auch noch ein Hinternis gestoßen.
Die Fett markierte Zeile im Code, definiert die Duplikate in der Spalte 5 (Spalte E). Ich möchte aber wie folgt ein Duplikat definieren:
Wenn in Spalte A gleiches Datum
Wenn in Spalte E gleiche Kunden-ID
Wenn in Spalte H gleiche Region
Wenn in Spalte N ungleich 0
und Wenn in Spalte P gleich 0
Ich hab folgendes im Internet dazu gefunden:
{=WENN(VERGLEICH(A1&B1&C1;A$1:A$100&B$1:B$100&C$1:C$100;0)=ZEILE();"";"Duplikat")}
Kann man die Formel auch irgendwie in VBA übertragen, sodass auch die Geschwindikeit nicht so sehr darunter leidet...
Ich bin leider da überfragt und hoffe auf professionelle Unterstützung.
Dafür auch vorab schon, vielen lieben Dank.
P.S.: Leider kann ich die dazugehörige Datei nicht anhängen. Dazu hatte ich hier eine Beispieldatei angelegt.

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread