.find -> Suche erst nach x Durchläufen erfogreich
24.05.2009 09:14:17
Suppenhuhn
Angehängte Makro-Routinen habe ich geschrieben um aus einer sehr, sehr langen Excel-Tapete die Zeilenpaare in ein neues Blatt auszusortieren, die in Spalte 13 bzw. 14 den gleichen Eintrag haben und deren Summe der Beträge in Spalte 17 gleich NULL sind.
Das Problem ist, dass das unten stehende Makro mehr als einen Durchlauf benötigt um alle Zeilenpaare zu finden.
Ich verstehe nicht weshalb das so ist.
Kann mir das bitte jemand erklären ?
Vielen Dank schonmal dafür ...
Suppi
Option Explicit
Dim Seitenname, Tabellenname, GenutzteReihen, Durchgang, Loeschgang, Gefunden, suchVsuch
Dim D, DD, I, II, LastI, X, Y, Z, Spalte
Dim SuchZeile, FindZeile, SuchBetrag, FindBetrag, Suchbegriff
Dim Auftrag, PSPElement
Dim LeereZeile, Gearbeitet As Boolean
Dim Fertig, Zeitmessung, ZeitMin, ZeitSek As Single
Dim ZM As Integer
Dim Sortierspalte As Range
Sub Aktivierungsbuchungen()
X = 0
Gefunden = 0
Durchgang = 0
Loeschgang = 0
Gearbeitet = False
LabelProgress.Width = 0
Tabellenname = "Aktivierungsbuchungen"
Seitenname = ActiveSheet.Name
GenutzteReihen = ActiveSheet.UsedRange.Rows.Count - 1
'MsgBox (GenutzteReihen)
For Y = 1 To Sheets.Count
If Worksheets(Y).Name = Tabellenname Then X = 1
Next Y
If X = 0 Then
Sheets.Add After:=Worksheets(Seitenname)
Worksheets(ActiveSheet.Name).Name = Tabellenname
Worksheets(Seitenname).Select
Worksheets(Seitenname).Rows(1).Copy
Worksheets(Tabellenname).Rows(1).Insert Shift:=xlDown
End If
Call Sortiere("P2")
Worksheets(Seitenname).Cells(1, 17).Select
Zeitmessung = Timer
Do
D = 0
Durchgang = Durchgang + 1
I = 0
Do
I = I + 1
Do
Auftrag = Worksheets(Seitenname).Cells(I, 14).Formula
PSPElement = Worksheets(Seitenname).Cells(I, 13).Formula
If Auftrag = "" And PSPElement = "" Then I = I + 1
If I >= GenutzteReihen Then Exit Do
Loop While Auftrag = "" And PSPElement = ""
SuchBetrag = Worksheets(Seitenname).Cells(I, 17).Value
If Not Auftrag = "" Then Call SuchMich(14, Auftrag)
If Not PSPElement = "" Then Call SuchMich(13, PSPElement)
GenutzteReihen = Worksheets(Seitenname).UsedRange.Rows.Count - 1
Fertig = I / GenutzteReihen
With Fortschrittsbalken
Me.Caption = Format(Fertig, "0%") & " der Aktivierungsbuchungen aussortiert! --- " & Durchgang & ".Durchgang"
.LabelProgress.BackColor = &HFF&
.LabelProgress.Width = Fertig * (.FrameProgress.Width - 5)
End With
DoEvents
Loop Until I >= GenutzteReihen
Call Sortiere("O2")
Loop While D > 0
Zeitmessung = Timer - Zeitmessung
ZeitMin = Round(Zeitmessung / 60, 0)
ZeitSek = Round(Zeitmessung - (ZeitMin * 60), 0)
Call Sortiere("O2")
Fortschrittsbalken.Hide
Application.StatusBar = "Fertig ..."
MsgBox ("Durchgänge: " & Durchgang & Chr(13) & Chr(13) & "Benötigte Zeit: " & ZeitMin & ":" & ZeitSek)
End Sub
Private Sub Sortiere(Sortierspalte)
Range("A1").Activate
Worksheets(Seitenname).Range("A1").Sort _
Key1:=Range(Sortierspalte), _
Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Worksheets(Seitenname).Cells(1, 17).Select
End Sub
Private Sub SuchMich(Spalte, Suchbegriff)
With Worksheets(Seitenname).Columns(Spalte)
Set Z = .Find(Suchbegriff, LookIn:=xlFormulas)
If Not Z Is Nothing Then
If Z.Row = I Then .FindNext (Z)
FindBetrag = Worksheets(Seitenname).Cells(Z.Row, 17).Value
If SuchBetrag 0 And SuchBetrag + FindBetrag = 0 Then
D = D + 1
FindZeile = Z.Row
Gearbeitet = True
Worksheets(Seitenname).Rows(I).Cut
Worksheets(Tabellenname).Rows(2).Insert Shift:=xlDown
Worksheets(Tabellenname).Cells(2, 20).Value = Durchgang
Worksheets(Tabellenname).Cells(2, 21).Value = I
Worksheets(Seitenname).Rows(FindZeile).Cut
Worksheets(Tabellenname).Rows(2).Insert Shift:=xlDown
Worksheets(Tabellenname).Cells(2, 20).Value = Durchgang
Worksheets(Tabellenname).Cells(2, 21).Value = FindZeile
Gefunden = Gefunden + 1
Application.StatusBar = Gefunden & " Aktivierungsbuchungen aussortiert ..."
If I > 2 Then
I = I - 2
Else
I = 1
End If
Else
.FindNext (Z)
End If
End If
End With
End Sub