12.10.2016, 10:08
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
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