Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1472to1476
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Loop ohne DO

Loop ohne DO
15.02.2016 07:50:01
thomas

Hallo Excelfreunde,
ich versuche gerade aus meiner Listbox die doppelten Einträge zu entfernen.
Mein erster Gedanke war Sie gar nicht erst einzulesen. ( Der unten stehende Code.
bei dieser Variante bekomme ich die Fehlermeldung "Loop ohne Do" und ich finde den Fehler nicht.
kann sich die dies bitte mal jemand anschauen?
Womöglich weiss jemand ein anderen Weg um die doppelten aus der Listbox zu entfernen.
Der abgleich ob doppelt oder nicht wäre diese Spalte.
"arr(3, iRowU) = .Cells(rng.Row, 2).Value ' Vorgangsnummer"
vielen dank schon vorab für eurer interesse.
liebe grüsse thomas

Private Sub CommandButton1_Click()
' Buttton sum suchen
Dim xSuche, xAdresse, xErste As String
Dim y As Boolean
Dim arr() As Variant
Dim rng As Range
Dim iRowU As Integer
Dim SuchWert As Variant
'für doppelte entfernen
Dim objDic As Object, strKey As String
Set objDic = CreateObject("scripting.dictionary")
TextBox2.Text = Split(txtSearch.Value, "-")(0)
ListBox1.Clear
If IsDate(TextBox2) Then
SuchWert = DateValue(TextBox2.Text)                        'CDate(TextBox2.Text)  ' suche  _
nach datum
Else
SuchWert = TextBox2         ' oder suche nach text
End If
Set rng = Worksheets("Vorgang").Range("C2:C3000, H2:H3000, k2:k3000").Find(SuchWert,  _
LookIn:=xlFormulas, lookat:=xlWhole)
'LookIn:=xlValues, LookAt:=xlWhole)
If Not rng Is Nothing Then
With Worksheets("Vorgang")
xErste = rng.Address(False, False)
y = True
Do Until xAdresse = xErste
' für doppelte
strKey = .Cells(rng.Row, 2)           ' doppelt
If Not objDic.Exist2s(strKey) Then   '  doppelt
objDic(strKey) = 1                ' doppelt
ReDim Preserve arr(0 To 23, 0 To iRowU)
'Debug.Print rng.Address
arr(0, iRowU) = .Name
arr(1, iRowU) = rng.Address(False, False)
arr(2, iRowU) = .Cells(rng.Row, 1).Value
arr(3, iRowU) = .Cells(rng.Row, 2).Value ' Vorgangsnummer
arr(4, iRowU) = .Cells(rng.Row, 3).Value
arr(5, iRowU) = .Cells(rng.Row, 4).Value
arr(6, iRowU) = .Cells(rng.Row, 5).Value
arr(7, iRowU) = .Cells(rng.Row, 6).Value
arr(8, iRowU) = .Cells(rng.Row, 7).Value
arr(9, iRowU) = .Cells(rng.Row, 8).Value
arr(10, iRowU) = .Cells(rng.Row, 9).Value
arr(11, iRowU) = Format(.Cells(rng.Row, 10).Value, "hh:mm")
arr(12, iRowU) = .Cells(rng.Row, 11).Value
arr(13, iRowU) = Format(.Cells(rng.Row, 12).Value, "hh:mm")
arr(14, iRowU) = .Cells(rng.Row, 13).Value
arr(15, iRowU) = .Cells(rng.Row, 14).Value
arr(16, iRowU) = .Cells(rng.Row, 15).Value
arr(17, iRowU) = .Cells(rng.Row, 16).Value
arr(18, iRowU) = .Cells(rng.Row, 17).Value
arr(19, iRowU) = .Cells(rng.Row, 18).Value
arr(20, iRowU) = .Cells(rng.Row, 19).Value
arr(21, iRowU) = .Cells(rng.Row, 20).Value
arr(22, iRowU) = .Cells(rng.Row, 21).Value
arr(23, iRowU) = .Cells(rng.Row, 22)
iRowU = iRowU + 1
Set rng = .Range("C2:C3000, H2:H3000, k2:k3000").FindNext(After:=rng)
xAdresse = rng.Address(False, False)
Debug.Print rng.Address
Loop
xAdresse = ""
xErste = ""
End With
End If
'End If
'Next iCounter
If y = False Then
'MsgBox "Hallo ich finde nichts"
Exit Sub
Else
objDic.RemoveAll
ListBox1.Column = arr
objDic.RemoveAll
Set objDic = Nothing
Exit Sub
End If
End Sub

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Loop ohne DO
15.02.2016 07:58:02
Gerd L
Hallo Thomas!
If Not objDic.Exist2s(strKey) Then ' doppelt
erwartet ein "End If" innerhalb der Schleife( oberhalb von "Loop" ).
Wegen deiner weiteren Fragen stelle ich den Beitrag auf "offen".
Gruß Gerd

AW: Loop ohne DO
15.02.2016 08:04:14
Crazy Tom
Hi
vor dem Loop gehört ein End If
Private Sub CommandButton1_Click()
' Buttton sum suchen
Dim xSuche, xAdresse, xErste As String
Dim y As Boolean
Dim arr() As Variant
Dim rng As Range
Dim iRowU As Integer
Dim SuchWert As Variant
Dim objDic As Object, strKey As String
Set objDic = CreateObject("scripting.dictionary")
TextBox2.Text = Split(txtSearch.Value, "-")(0)
ListBox1.Clear
If IsDate(TextBox2) Then
SuchWert = DateValue(TextBox2.Text)
Else
SuchWert = TextBox2         ' oder suche nach text
End If
Set rng = Worksheets("Vorgang").Range("C2:C3000, H2:H3000, k2:k3000").Find(SuchWert, _
LookIn:=xlFormulas, lookat:=xlWhole)
If Not rng Is Nothing Then
With Worksheets("Vorgang")
xErste = rng.Address(False, False)
y = True
Do Until xAdresse = xErste
strKey = .Cells(rng.Row, 2)           ' doppelt
If Not objDic.Exist2s(strKey) Then   '  doppelt
objDic(strKey) = 1                ' doppelt
ReDim Preserve arr(0 To 23, 0 To iRowU)
arr(0, iRowU) = .Name
arr(1, iRowU) = rng.Address(False, False)
arr(2, iRowU) = .Cells(rng.Row, 1).Value
arr(3, iRowU) = .Cells(rng.Row, 2).Value ' Vorgangsnummer
arr(4, iRowU) = .Cells(rng.Row, 3).Value
arr(5, iRowU) = .Cells(rng.Row, 4).Value
arr(6, iRowU) = .Cells(rng.Row, 5).Value
arr(7, iRowU) = .Cells(rng.Row, 6).Value
arr(8, iRowU) = .Cells(rng.Row, 7).Value
arr(9, iRowU) = .Cells(rng.Row, 8).Value
arr(10, iRowU) = .Cells(rng.Row, 9).Value
arr(11, iRowU) = Format(.Cells(rng.Row, 10).Value, "hh:mm")
arr(12, iRowU) = .Cells(rng.Row, 11).Value
arr(13, iRowU) = Format(.Cells(rng.Row, 12).Value, "hh:mm")
arr(14, iRowU) = .Cells(rng.Row, 13).Value
arr(15, iRowU) = .Cells(rng.Row, 14).Value
arr(16, iRowU) = .Cells(rng.Row, 15).Value
arr(17, iRowU) = .Cells(rng.Row, 16).Value
arr(18, iRowU) = .Cells(rng.Row, 17).Value
arr(19, iRowU) = .Cells(rng.Row, 18).Value
arr(20, iRowU) = .Cells(rng.Row, 19).Value
arr(21, iRowU) = .Cells(rng.Row, 20).Value
arr(22, iRowU) = .Cells(rng.Row, 21).Value
arr(23, iRowU) = .Cells(rng.Row, 22)
iRowU = iRowU + 1
Set rng = .Range("C2:C3000, H2:H3000, k2:k3000").FindNext(After:=rng)
xAdresse = rng.Address(False, False)
Debug.Print rng.Address
End If
Loop
xAdresse = ""
xErste = ""
End With
If y = False Then
'MsgBox "Hallo ich finde nichts"
Exit Sub
Else
objDic.RemoveAll
ListBox1.Column = arr
objDic.RemoveAll
Set objDic = Nothing
Exit Sub
End If
End If
End Sub
ungetestet
MfG Tom

Anzeige
AW: Loop ohne DO
15.02.2016 08:14:48
Daniel
Hi
Die Fehlermeldung ist etwas verwirrend, aber es fehlt nicht das DO, sondern das END IF für das erste If nach dem DO :
If Not objDic.Exist2s(strKey) Then ' doppelt
Wie kommt es dazu?
1. Der Compiler prüft den Code von oben nach unten
2. Schleifen und If-Blöcke dürfen in einander verschränkt, sondern müssen ineinander geschachtelten werden.
Dein erstes Do steht außerhalb des If-Block, das Loop dazu jedoch innerhalb, weil das EndIf noch nicht erschienen ist. Damit müssen nach 2. das DO und das LOOP zu unterschiedlichen Schleifen gehören.
Da das Loop für das erste Do noch kommen kann, ist det erste auftretende Fehler das fehlende Do für das Loop, weil dieses vor dem Loop, aber innerhalb des If-Blocks stehen müsste und da fehlt es.
Gruß Daniel

Anzeige
AW: Loop ohne DO
15.02.2016 09:05:49
thomas
Hallo Excelfreunde,
cool das Ihr den Fehler so schnell gefunden habt. Habt recht vielen dank dafür.
Das dumme ist ich muss noch ein weitern fehler drin haben, in dieser Zeile
"If Not objDic.Exist2s(strKey) Then " kommt die Fehlermeldung
" objekt unterstützt diese Eigenschaft nicht"
könnte es am Format liegen?
das Format für die doppelten einträge ist z.B. 0123-15
liebe grüsse thomas

Exist2s does not exist
15.02.2016 09:13:36
RPP63
Müsste Dir aber eigentlich auffallen?
Gruß Ralf

AW: Exist2s does not exist
15.02.2016 11:27:05
thomas
Hallo Ralf,
ich bin im VBA nicht gut um nicht zu sagen sehr schlecht.
Kannst Du mir noch ein Hinweis mit der Keule geben ?
Der code unten läuft jetzt zwar durch mit "If Not objDic.Exists(strKey) Then " jedoch nur wenn keine doppelten da sind. Sowie ein doppelter da ist hängt sich Excel auf und irgendwann ( dauert sehr lange) bekomme ich die Meldung " Automatisierungsfehler) das aufgerufene Objekt wurde getrennt. Und excel bricht komplett zusammmen.
Hm bin ratlos. hast Du noch ein Tipp?
ich hoffe das ich den Code nicht ganz verhunzt habe.
liebe grüsse thomas
Private Sub CommandButton1_Click()
' Buttton sum suchen
Dim xSuche, xAdresse, xErste As String
Dim y As Boolean
Dim arr() As Variant
Dim rng As Range
Dim iRowU As Integer
Dim SuchWert As Variant
Dim objDic As Object, strKey As String
Set objDic = CreateObject("scripting.dictionary")
TextBox2.Text = Split(txtSearch.Value, "-")(0)
ListBox1.Clear
If IsDate(TextBox2) Then
SuchWert = DateValue(TextBox2.Text)                        'CDate(TextBox2.Text)  ' suche  _
nach datum
Else
SuchWert = TextBox2         ' oder suche nach text
End If
Set rng = Worksheets("Vorgang").Range("C2:C3000, H2:H3000, k2:k3000").Find(SuchWert,  _
LookIn:=xlFormulas, lookat:=xlWhole)
'LookIn:=xlValues, LookAt:=xlWhole)
If Not rng Is Nothing Then
With Worksheets("Vorgang")
xErste = rng.Address(False, False)
y = True
Do Until xAdresse = xErste
strKey = Worksheets("Vorgang").Cells(rng.Row, 3)           ' doppelt
If Not objDic.Exists(strKey) Then   '  doppelt
objDic(strKey) = 1                ' doppelt
ReDim Preserve arr(0 To 23, 0 To iRowU)
Debug.Print rng.Address
arr(0, iRowU) = .Name
arr(1, iRowU) = rng.Address(False, False)
arr(2, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 1).Value
arr(3, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 2).Value '  _
Vorgangsnummer
arr(4, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 3).Value
arr(5, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 4).Value
arr(6, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 5).Value
arr(7, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 6).Value
arr(8, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 7).Value
arr(9, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 8).Value
arr(10, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 9).Value
arr(11, iRowU) = Format(Worksheets("Vorgang").Cells(rng.Row, 10).Value, "hh: _
mm")
arr(12, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 11).Value
arr(13, iRowU) = Format(Worksheets("Vorgang").Cells(rng.Row, 12).Value, "hh: _
mm")
arr(14, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 13).Value
arr(15, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 14).Value
arr(16, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 15).Value
arr(17, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 16).Value
arr(18, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 17).Value
arr(19, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 18).Value
arr(20, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 19).Value
arr(21, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 20).Value
arr(22, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 21).Value
arr(23, iRowU) = Worksheets("Vorgang").Cells(rng.Row, 22)
iRowU = iRowU + 1
Set rng = Worksheets("Vorgang").Range("C2:C3000, H2:H3000, k2:k3000"). _
FindNext(After:=rng)
xAdresse = rng.Address(False, False)
' Debug.Print rng.Address
End If
Loop
xAdresse = ""
xErste = ""
End With
End If
'End If
'Next iCounter
If y = False Then
MsgBox "Hallo ich finde nichts"
Exit Sub
Else
ListBox1.Column = arr
Exit Sub
objDic.RemoveAll
End If
Set objDic = Nothing
End Sub

Anzeige
AW: Exist2s does not exist
15.02.2016 12:03:22
Daniel
Hi
gehe mal davon aus, dass du dein End If falsch platziert hast.
das
Set rng = Worksheets("Vorgang").Range("C2:C3000, H2:H3000, k2:k3000").FindNext(After:=rng)
xAdresse = rng.Address(False, False)
sollte wahrscheinlich bei jedem Schleifenumlauf ausgeführt werden.
daher muss das END IF vor diesen beiden Zeilen stehen und nicht direkt vor dem Loop.
Gruß Daniel

super es passt
15.02.2016 12:39:49
thomas
Hallo daniel,
du es es erwischt es kommt vor,
"Set rng = Worksheets("Vorgang").Range("C2:C3000, H2:H3000, k2:k3000").FindNext(After:=rng)"
dann passt alles.
habt alle recht vielen dank für die super Hilfe
viele liebe grüsse thomas

Anzeige

63 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige