Excel vba braucht sehr lange

Hallo,
kann mir jemand erklären warum der Code ca. 2 minuten zum Ausführen benötigt?
Ich vermute das es mit den Variablen zusammenhängt, denn eine andere Kopiermethode oder ein Fehler direkt am Anfang der Schleife hat die Zeit nicht verkürzt.

Private Sub CommandButton1_Click()
'Datenbank kopieren (Abas Zusatzdatenbank --> Filterbearbeitung)
Worksheets("Abas Zusatzdatenbank").Columns("A:J").Copy Destination:=Worksheets(" _
Filterbearbeitung").Range("A1")
'Löschen der Zeilen, welche das Filterkriterium nicht erfüllen
Dim artikelnummer As String
Dim kanbanlagerort As String
Dim füllgröße As String
Dim behälterart As String
Dim liefer As String
Dim kanbanart As String
Dim sparte As String
Dim lieferant As String
artikelnummer = Sheets("Lagerplatz Verwaltung").Cells(27, 14).Value
kanbanlagerort = Sheets("Lagerplatz Verwaltung").Cells(27, 15).Value
füllgröße = Sheets("Lagerplatz Verwaltung").Cells(27, 17).Value
behälterart = Sheets("Lagerplatz Verwaltung").Cells(27, 18).Value
liefer = Sheets("Lagerplatz Verwaltung").Cells(27, 19).Value
kanbanart = Sheets("Lagerplatz Verwaltung").Cells(27, 20).Value
sparte = Sheets("Lagerplatz Verwaltung").Cells(27, 21).Value
lieferant = Sheets("Lagerplatz Verwaltung").Cells(27, 22).Value
'Löschen der Zeilen, welche das Filterkriterium nicht erfüllen
Dim max As Long
max = Sheets("Filterbearbeitung").Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = max To 1 Step -1
If Not IsError(Sheets("Filterbearbeitung").Cells(i, 2).Value) Then
If Sheets("Filterbearbeitung").Cells(i, 2).Value  artikelnummer And Not artikelnummer = "" _
Then
Sheets("Filterbearbeitung").Rows(i).Delete
GoTo Ende
End If
End If
If Not IsError(Sheets("Filterbearbeitung").Cells(i, 3).Value) Then
If Sheets("Filterbearbeitung").Cells(i, 3).Value  kanbanlagerort And Not kanbanlagerort =  _
"" Then
Sheets("Filterbearbeitung").Rows(i).Delete
GoTo Ende
End If
End If
If Not IsError(Sheets("Filterbearbeitung").Cells(i, 5).Value) Then
If Sheets("Filterbearbeitung").Cells(i, 5).Value  füllgröße And Not füllgröße = "" Then
Sheets("Filterbearbeitung").Rows(i).Delete
GoTo Ende
End If
End If
If Not IsError(Sheets("Filterbearbeitung").Cells(i, 6).Value) Then
If Sheets("Filterbearbeitung").Cells(i, 6).Value  behälterart And Not behälterart = ""  _
Then
Sheets("Filterbearbeitung").Rows(i).Delete
GoTo Ende
End If
End If
If Not IsError(Sheets("Filterbearbeitung").Cells(i, 7).Value) Then
If Sheets("Filterbearbeitung").Cells(i, 7).Value  liefer And Not liefergeorg = "" Then
Sheets("Filterbearbeitung").Rows(i).Delete
GoTo Ende
End If
End If
If Not IsError(Sheets("Filterbearbeitung").Cells(i, 8).Value) Then
If Sheets("Filterbearbeitung").Cells(i, 8).Value  kanbanart And Not kanbanart = "" Then
Sheets("Filterbearbeitung").Rows(i).Delete
GoTo Ende
End If
End If
If Not IsError(Sheets("Filterbearbeitung").Cells(i, 9).Value) Then
If Sheets("Filterbearbeitung").Cells(i, 9).Value  sparte And Not sparte = "" Then
Sheets("Filterbearbeitung").Rows(i).Delete
GoTo Ende
End If
End If
If Not IsError(Sheets("Filterbearbeitung").Cells(i, 10).Value) Then
If Sheets("Filterbearbeitung").Cells(i, 10).Value  lieferant And Not lieferant = "" Then
Sheets("Filterbearbeitung").Rows(i).Delete
GoTo Ende
End If
End If
Ende:
Next i
End Sub

MfG Matthias

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton1_Click() 'Datenbank kopieren (Abas Zusatzdatenbank --> Filterbearbeitung) Worksheets("Abas Zusatzdatenbank").Columns("A:J").Copy _ Destination:=Worksheets("Filterbearbeitung").Range("A1") 'Löschen der Zeilen, welche das Filterkriterium nicht erfüllen Dim ArtikelNummer As String Dim KanbanLagerort As String Dim FüllGröße As String Dim BehälterArt As String Dim liefer As String Dim KanbanArt As String Dim sparte As String Dim lieferant As String Dim bolFound As Boolean Dim rngDel As Range With Sheets("Lagerplatz Verwaltung") ArtikelNummer = .Cells(27, 14).Value KanbanLagerort = .Cells(27, 15).Value FüllGröße = Cells(27, 17).Value BehälterArt = .Cells(27, 18).Value liefer = .Cells(27, 19).Value KanbanArt = .Cells(27, 20).Value sparte = .Cells(27, 21).Value lieferant = .Cells(27, 22).Value End With 'Löschen der Zeilen, welche das Filterkriterium nicht erfüllen Dim max As Long With Sheets("Filterbearbeitung") max = .Cells(Rows.Count, 1).End(xlUp).Row + 1 For i = 1 To max bolFound = False If Not IsError(.Cells(i, 2).Value) Then If .Cells(i, 2).Value ArtikelNummer And Not ArtikelNummer = "" Then bolFound = True End If End If If Not IsError(.Cells(i, 3).Value) Then If .Cells(i, 3).Value KanbanLagerort And Not KanbanLagerort = "" Then bolFound = True End If End If If Not IsError(.Cells(i, 5).Value) Then If .Cells(i, 5).Value FüllGröße And Not FüllGröße = "" Then bolFound = True End If End If If Not IsError(.Cells(i, 6).Value) Then If .Cells(i, 6).Value BehälterArt And Not BehälterArt = "" Then bolFound = True End If End If If Not IsError(.Cells(i, 7).Value) Then If .Cells(i, 7).Value liefer And Not liefergeorg = "" Then bolFound = True End If End If If Not IsError(.Cells(i, 8).Value) Then If .Cells(i, 8).Value KanbanArt And Not KanbanArt = "" Then bolFound = True End If End If If Not IsError(.Cells(i, 9).Value) Then If .Cells(i, 9).Value sparte And Not sparte = "" Then bolFound = True End If End If If Not IsError(.Cells(i, 10).Value) Then If .Cells(i, 10).Value lieferant And Not lieferant = "" Then bolFound = True End If End If If bolFound Then If rngDel Is Nothing Then Set rngDel = .Rows(i) Else Set rngDel = Union(rngDel, .Rows(i)) End If End If Next i End With If Not rngDel Is Nothing Then rngDel.Delete End Sub

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excel vba braucht sehr lange

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread