VBA - Sverweis für Adressen mit Löschen doppelter Werte

[ABCDE]

Hallo zusammen,

ich bin dabei ein Makro für eine Adressliste zu erstellen und dabei die doppelten Werte zu löschen. Meine Exceldateien sehen meist immer so aus:

1 Hans-Böcklerstr. 1
1 Hans-Böcklerstr. 2
1 Marienstr. 1
1 Marienstr. 2

Die 1 ist in Spalte A und die Adresse in B. Ich möchte nun, wenn ich nach der 1 suche folgendes Ergebnis erhalten:

 Hans-Böcklerstr. 1, 2, Marienstr. 1, 2

Ich hatte dafür schon ein Makro für einen Sverweis (="myvlookup" - siehe Code unten) geschrieben bzw. mir aus dem Internet zusammengesucht, jedoch erhalte ich folgendes Ergebnis. 

Hans-Böcklerstr. 1, 2, Marienstr. 2

Das Problem liegt hier, denke ich, bei der "Removedupes2 Funktion", da er alles als Text erkennt und folglich die doppelte 1 bei der Marienstr. löscht.

Hat einer eine Idee? :)

Vielen Dank schon einmal vorab :) 

Anbei ist noch mein Code: 

Function StrSort(ByVal sInp As String, _
    Optional bDescending As Boolean = False) As String
     ' sorts a comma-delimited string
    Dim asSS()  As String ' substring array
    Dim sSS     As String ' temp string for exchange
    Dim n       As Long
    Dim i       As Long
    Dim j       As Long
     
    asSS = Split(sInp, ",")
    n = UBound(asSS)
     
    For i = 0 To n
        asSS(i) = Trim(asSS(i))
    Next
     
    If n <= 1 Then
        StrSort = sInp
    Else
        For i = 0 To n - 1
            For j = i + 1 To n
                If (asSS(j) < asSS(i)) Xor bDescending Then
                    sSS = asSS(i)
                    asSS(i) = asSS(j)
                    asSS(j) = sSS
                End If
            Next j
        Next i
        StrSort = Join(asSS, ", ")
    End If
End Function

Function RemoveDupes2(txt As String, Optional delim As String = " ") As String
    Dim x
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For Each x In Split(txt, delim)
            If Trim(x) <> "" And Not .exists(Trim(x)) Then .Add Trim(x), Nothing
        Next
        If .Count > 0 Then RemoveDupes2 = Join(.keys, delim)
    End With
End Function

Function Myvlookup(lookupval, lookuprange As Range, indexcol As Long)

Dim r As Range
Dim result As String
Dim result2 As String
Dim result3 As String
result = ""
For Each r In lookuprange
    If r = lookupval Then
        result = result & ", " & r.Offset(0, indexcol - 1)
    End If
Next r

result2 = Right(result, Len(result) - 2)

result3 = StrSort(result2)
Myvlookup = RemoveDupes2(result3)
End Function

[Kuwer]

Hallo,

ersetze mal Deine Funktion Removedupes2 durch folgende:

Function RemoveDupes2(ByVal strTxt As String, Optional strDelim As String = " ") As String
 Dim varTxt As Variant
 Dim x As Long
 varTxt = Split(strTxt, strDelim)
 For x = UBound(varTxt) - 1 To 2 Step -2
   If Trim(varTxt(x)) = Trim(varTxt(x - 2)) Then varTxt(x) = ""
 Next
 RemoveDupes2 = Join(varTxt, strDelim)
End Function

Gruß Uwe

[ABCDE]

Hallo Uwe,

die Funktion macht genau das was ich will.


Vielen Dank!!!