array sortieren und doppelte löschen danach zurück

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Ich habe eine Tabelle in der ich Gerätespezifische Daten eingebe, z.B. Bezeichnung, Seriennummer u.ä..
Auf der eigentlichen Seite gebe ich nun die Seriennummer ein, nach der ich suchen will. Das Ergebnis lasse ich mir dann in einer Auflistung anzeigen. Nun kann es vorkommen, dass es identische Seriennummern gibt, aber bei verschiedenen Geräten.
Nun werden mir alle Bezeichnungen mit der fraglichen SN in ein Array gelesen.
Hier beginnt das Prob, dass mir da auch doppelte Bezeichnungen angezeigt werden. Diese will ich nun eliminieren und alle Bezeichnungen nur einmal in einem anderne Array speichern, damit ich dann später in einem Auswahlmenu darauf zurückgreifen kann.
Danke schon einmal für Deine Unterstützung. Gruß, Hardy

Sub Test() Dim ARR1, ARR2 ARR1 = Array("TEST0", "TEST0", "TEST6", "TEST3", "TEST7", "TEST6") ARR2 = Array("") ReDim Preserve ARR1(UBound(ARR1)) For Count1 = LBound(ARR1) To UBound(ARR1) Varic = ARR1(Count1) If InStr(VariN, Varic) > 0 Then Else VariN = CStr(VariN) & "," & CStr(Varic) VariNAnz = VariNAnz + 1 If Left(VariN, 1) = "," Then VariN = Right(VariN, Len(VariN) - 1) End If End If Next Count1 ReDim Preserve ARR2(VariNAnz - 1) For Count2 = 0 To VariNAnz - 1 If InStr(VariN, ",") > 0 Then ARR2(Count2) = Left(VariN, InStr(VariN, ",") - 1) VariN = Right(VariN, Len(VariN) - InStr(VariN, ",")) Else ARR2(Count2) = VariN End If Next Count2 End Sub

Sub Test() Dim ARR1, ARR2 ARR1 = Array("") ARR2 = Array("") '#########ARR1 befüllen start############ VariAnz0 = 8 'hier woher auch immer die gesamt Anzahl der durchläufe For Count0 = 0 To VariAnz0 - 1 VariN0 = ActiveSheet.Cells(Count0 + 1, 2) ' dieser variablen solltest du deinen _ wert übergeben (mein eintrag ist ein bsp) If InStr(VariN0, ",") > 0 Then ARR1(Count0) = Left(VariN0, InStr(VariN0, ",") - 1) VariN0 = Right(VariN0, Len(VariN0) - InStr(VariN0, ",")) Else ARR1(Count0) = VariN0 End If ReDim Preserve ARR1(UBound(ARR1) + 1) Next Count0 '#########ARR1 befüllen ende############ For Count1 = LBound(ARR1) To UBound(ARR1) Varic = ARR1(Count1) If InStr(VariN, Varic) > 0 Then Else VariN = CStr(VariN) & "," & CStr(Varic) VariNAnz = VariNAnz + 1 If Left(VariN, 1) = "," Then VariN = Right(VariN, Len(VariN) - 1) End If End If Next Count1 ReDim Preserve ARR2(VariNAnz - 1) For Count2 = 0 To VariNAnz - 1 If InStr(VariN, ",") > 0 Then ARR2(Count2) = Left(VariN, InStr(VariN, ",") - 1) VariN = Right(VariN, Len(VariN) - InStr(VariN, ",")) Else ARR2(Count2) = VariN End If Next Count2 End Sub

Danke, werde das mit dem neuen Code mal probieren.
Bislang sah es bei mir so aus:


Private Sub Worksheet_Change(ByVal Target As Range)
Dim geraet(100), auswahl(10) As String
Dim i, j, k, l, endzeile, endzeile2 As Integer
Dim flag, flag2 As Byte
Dim sn As String
'geänderte Zelle wird überprüft
If Target.Address = Range("snsuche").Address Then
Sheets("karte").Range("a6:f300").Value = ""
sn = Target.Value
flag = 0
'Wenn Zielzelle leer ist dann wird die Tabelle gesäubert
If sn = "" Then
Sheets("karte").Range("a6:f300").Value = ""
End If
'Auslesen der letzten zeile aus dem Blatt Lebenslauf
endzeile = Sheets("lebenslauf").Range("a:a").End(xlDown).Row
endzeile2 = Sheets("uebersicht").Range("a:a").End(xlDown).Row
'Überprüfung ob es die SN überhaupt gibt und Ausgabe der entsprechenden Daten
k = 6
'übung
l = 0
'alle gerätebezeihcnungen sind im array
For i = 0 To 100
geraet(i) = ""
Next i
For i = 0 To 10
auswahl(i) = ""
Next i
For i = 1 To endzeile
If Sheets("lebenslauf").Range("d" & i).Value = sn Then
geraet(l) = Sheets("lebenslauf").Range("c" & i).Value
l = l + 1
End If
Next i
'array auf doppelte einträge unteruschen
auswahl(0) = geraet(0)
For i = 1 To 100
If geraet(i) <> "" Then
flag = 0
l = 0
Do
If auswahl(l) = geraet(i) Then
l = l + 1
Else
For j = 1 To 10
If auswahl(j) <> "" Then
Else
flag = j
Exit For
End If
Next j
auswahl(flag) = geraet(i)
Exit Do
End If
Loop
Else
Exit For
End If
Next i
'kontrollanzeige geräte
For i = 0 To 10
If auswahl(i) <> "" Then
MsgBox auswahl(i)
Else
Exit For
End If
Next i
'original
flag = 0
For i = 1 To endzeile
If Sheets("lebenslauf").Range("d" & i).Value = sn Then
flag = 1
Sheets("karte").Range("a" & k).Value = Sheets("lebenslauf").Range("a" & i).Value
Sheets("karte").Range("b" & k).Value = Sheets("lebenslauf").Range("c" & i).Value
Sheets("karte").Range("c" & k).Value = Sheets("lebenslauf").Range("e" & i).Value
Sheets("karte").Range("d" & k).Value = Sheets("lebenslauf").Range("b" & i).Value
Sheets("karte").Range("f" & k).Value = Sheets("lebenslauf").Range("f" & i).Value
For j = 1 To endzeile2
If Sheets("uebersicht").Range("a" & j).Value = Sheets("karte").Range("d" & k).Value Then
Sheets("karte").Range("e" & k).Value = Sheets("uebersicht").Range("b" & j).Value
End If
Next j
k = k + 1
End If
Next i
If flag = 0 Then
MsgBox "Die angegebene Seriennummer existiert nicht!!", vbInformation, "Falsche Seriennummer"
End If
Range("A5:F22").Select
Selection.sort Key1:=Range("A6"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("C2").Select
End If
End Sub

Es soll so sein, dass ich in dem Blatt "Lebenslauf" die gerätespezifischen Daten eingebe. Nun werden bei jedem Durchlauf in der Werkstatt immer neue Arbeiten am gleichen Gerät durchgeführt. Somit erscheint die Geraätebezeichnung mehr als einmal.
das Blatt "Karte" soll mir eine Übersicht über die an einem bestimmten Gerät durchgeführten arbeiten geben. Das bedeutet, dass ich als Suchkreterium die Seriennummer eingebe. Damit vergleicht er nun in dem Lebenslauf und sucht mir die passenden Geräte heraus. Diese gesamten Gerätebezeichnungen soll er mir nun in ein Array schreiben. Hier war/ist nun mein Problem, dass er mir alle gleichen Gerätebezeichnungen herausfiltern soll und die übrigen in ein neues/altes Array schreibt. Mit diesen neuen Werten will ich später in einem Userform Radiobuttons füttern - als Auswahloption.
Bald komme ich ins schleudern....
Danke Dir jedenfalls noch einmal recht herzlich. Deinen neuen Code werde ich asap ausprobieren.
Bis dann, Hardy

Beliebteste Forumthreads (12 Monate)

array sortieren und doppelte löschen danach zurück

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

array sortieren und doppelte löschen danach zurück

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread