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