Makro/Lösung gesucht für Doppelte Werte innerhalb einer Zelle löschen

[Tibor]

Hallo,

ich habe etliche Wörter in einer Zelle wo Doppelte Werte vorkommen können und das in ca. 1000 Reihen. Ich habe schonmal ein Makro herausgefischt, was auch läuft, jedoch nur bei einer Zelle. Den code habe ich auf ("A1:A1000") bearbeitet, geht dann aber nicht mehr. Bitte um Hilfe !!! :(

Sub x()
   Dim ar As Variant, i As Long, objDic As Object
   
   Set objDic = CreateObject("scripting.dictionary")
   ar = Split(Range("A1").Value, " ")
   For i = 0 To UBound(ar)
      objDic(ar(i)) = 1
   Next
   Range("A1").Value = Join(objDic.Keys, " ")
   Set objDic = Nothing
End Sub

[Storax]

Code:

Option Explicit

Sub removeDuplicates(ByRef ar As Variant)
   Dim i As Long, objDic As Object
 
   Set objDic = CreateObject("scripting.dictionary")
   ar = Split(ar, " ")
   For i = 0 To UBound(ar)
       objDic(ar(i)) = 1
   Next
   ar = Join(objDic.Keys, " ")
   
End Sub

Sub removeDuplicatesInRange()
   Dim wks As Worksheet
   Dim rg As Range
   Set wks = ActiveSheet
   Set rg = wks.Range("A1:A1000")
   
   Dim vDat As Variant
   vDat = WorksheetFunction.Transpose(rg)
   
   Dim i As Long
   For i = LBound(vDat) To UBound(vDat)
       removeDuplicates vDat(i)
   Next
   
   rg = WorksheetFunction.Transpose(vDat)
   
End Sub

[Tibor]

Danke, das läuft schonmal besser, aber nach größeren Datenmengen hängt der sich auf. Fehlermeldung: run time error 13 type mismatch

im VBA wird folgendes Gelb markiert: rg = WorksheetFunction.Transpose(vDat)

[00202]

Hallo Storax, :19:

dein Code läuft bei mir recht langsam. Das dürfte daran liegen, dass du in der Schleife bei jedem Aufruf das "CreateObject("scripting.dictionary")" neu initialisierst.
Ich habe es mal über eine Schleife "Sub x()" und mit einem Array "Sub y()" gemacht: :21:

Code:

Option Explicit
Sub x()
    Dim ar As Variant, I As Long, j As Long, objDic As Object
    Set objDic = CreateObject("scripting.dictionary")
    For j = 1 To Application.Max(1, Cells(Rows.Count, 1).End(xlUp).Row)
        ar = Split(Range("A" & j).Value, " ")
        For I = 0 To UBound(ar)
            objDic(ar(I)) = 1
        Next I
        Range("A" & j).Value = Join(objDic.Keys, " ")
    Next j
    Set objDic = Nothing
End Sub
Sub y()
    Dim ar As Variant, I As Long, j As Long, objDic As Object, ArrayA() As Variant
    Set objDic = CreateObject("scripting.dictionary")
    ArrayA = Range("A1:A" & Application.Max(1, Cells(Rows.Count, 1).End(xlUp).Row)).Value
    For j = LBound(ArrayA) To UBound(ArrayA)
        ar = Split(ArrayA(j, 1), " ")
        For I = 0 To UBound(ar)
            objDic(ar(I)) = 1
        Next I
        ArrayA(j, 1) = Join(objDic.Keys, " ")
    Next j
    Cells(1, 1).Resize(UBound(ArrayA, 1), UBound(ArrayA, 2)) = ArrayA
    Set objDic = Nothing
End Sub

Die Zeitmessung hat auf meinem PC ergeben (bei 3.000 Datensätzen):

Sub removeDuplicatesInRange() ---> 3,656 Sekunden
Sub x()                                     ---> 0,344 Sekunden 
Sub y()                                     ---> 0,047 Sekunden

[Storax]

@Tibor: Solll ich jetzt raten?

Wie sieht der aktuelle Code aus, den Du verwendest.
Ein MCVE ist nötig!

@Case: Das ist nicht mein Code! Ich habe nur die Schleife dazu gebaut.
Der OP kann ja auch was tun.

Update: ohne Verwendung der Scripting Runtime
@Case: Jetzt ist das mein Code

Code:

Option Explicit

Const DELIMITER = " "

Function removeDuplicatesInString(ByVal inp As String) As String
    
    Dim inpArr() As String
    Dim result As String
    
    inpArr = Split(inp, DELIMITER)
    result = DELIMITER
    
    Dim i As Long
    For i = LBound(inpArr) To UBound(inpArr)
        If InStr(result, DELIMITER & Trim(inpArr(i)) & DELIMITER) = 0 Then _
            result = result & Trim(inpArr(i)) & DELIMITER
    Next i
    
    removeDuplicatesInStringA = Right(result, Len(result) - 1)
End Function


Sub removeRange()
   Dim wks As Worksheet
   Dim rg As Range
   Set wks = ActiveSheet
   Set rg = wks.Range("A1:A55")
   
   Dim vDat As Variant
   vDat = WorksheetFunction.Transpose(rg)
   
   Dim i As Long
   For i = LBound(vDat) To UBound(vDat)
       vDat(i) = removeDuplicatesInString(vDat(i))
   Next
   
   rg.Value2 = WorksheetFunction.Transpose(vDat)
   
End Sub

[schauan]

Hallöchen,

was sind denn größere Datenmengen bzw. welchen Bereich hast Du definiert?
Bei mir läuft das problemlos:

Code:

Sub test()
Dim wks As Worksheet
Dim rg As Range
Set wks = ActiveSheet
Dim i&
For i = 1 To 1000 Step 10
   Set rg = wks.Range("A1:X" & 1000 * i)
   Dim vDat As Variant
   vDat = WorksheetFunction.Transpose(rg)
Next
End Sub

Einen Fehler 13 bekomme ich z.B., wenn ich das Makro auf einem Diagrammblatt ausführen will …

[Tibor]

Danke für die codes! Leider läuft keines bei mir wie es sollte.

@ storax: Ich habe Dein code reinkopiert wie Du es gesendet hast. Bei ca. 10 zeilen funktioniert es, aber bei knappen 1000 Reihen nicht mehr. Wie bekomme ich ein MCVE?

Code:

Option Explicit

Sub removeDuplicates(ByRef ar As Variant)
   Dim i As Long, objDic As Object
 
   Set objDic = CreateObject("scripting.dictionary")
   ar = Split(ar, " ")
   For i = 0 To UBound(ar)
       objDic(ar(i)) = 1
   Next
   ar = Join(objDic.Keys, " ")
   
End Sub

Sub removeDuplicatesInRange()
   Dim wks As Worksheet
   Dim rg As Range
   Set wks = ActiveSheet
   Set rg = wks.Range("A1:A1000")
   
   Dim vDat As Variant
   vDat = WorksheetFunction.Transpose(rg)
   
   Dim i As Long
   For i = LBound(vDat) To UBound(vDat)
       removeDuplicates vDat(i)
   Next
   
   rg = WorksheetFunction.Transpose(vDat)
   
End Sub

[00202]

Hallo, :19:

mache eine aussagekräftige Beispieldatei und lade sie hier hoch - dann schaut schon einer von uns drüber. :21:

[Tibor]

Hallo Storax, :19:

dein Code läuft bei mir recht langsam. Das dürfte daran liegen, dass du in der Schleife bei jedem Aufruf das "CreateObject("scripting.dictionary")" neu initialisierst.
Ich habe es mal über eine Schleife "Sub x()" und mit einem Array "Sub y()" gemacht: :21:

Code:

Option Explicit
Sub x()
    Dim ar As Variant, I As Long, j As Long, objDic As Object
    Set objDic = CreateObject("scripting.dictionary")
    For j = 1 To Application.Max(1, Cells(Rows.Count, 1).End(xlUp).Row)
        ar = Split(Range("A" & j).Value, " ")
        For I = 0 To UBound(ar)
            objDic(ar(I)) = 1
        Next I
        Range("A" & j).Value = Join(objDic.Keys, " ")
    Next j
    Set objDic = Nothing
End Sub
Sub y()
    Dim ar As Variant, I As Long, j As Long, objDic As Object, ArrayA() As Variant
    Set objDic = CreateObject("scripting.dictionary")
    ArrayA = Range("A1:A" & Application.Max(1, Cells(Rows.Count, 1).End(xlUp).Row)).Value
    For j = LBound(ArrayA) To UBound(ArrayA)
        ar = Split(ArrayA(j, 1), " ")
        For I = 0 To UBound(ar)
            objDic(ar(I)) = 1
        Next I
        ArrayA(j, 1) = Join(objDic.Keys, " ")
    Next j
    Cells(1, 1).Resize(UBound(ArrayA, 1), UBound(ArrayA, 2)) = ArrayA
    Set objDic = Nothing
End Sub

Die Zeitmessung hat auf meinem PC ergeben (bei 3.000 Datensätzen):

Sub removeDuplicatesInRange() ---> 3,656 Sekunden
Sub x()                                     ---> 0,344 Sekunden 
Sub y()                                     ---> 0,047 Sekunden

Der code läuft zwar bei mir durch aber nicht wie gewünscht. Der text verlängert sich nach fast jeder zeile.....

[Storax]

Lesen ist nicht Deine Stärke, ich habe eine Erklärung verlinkt.

Aber ich rate mal, dass in den Input Daten Fehlerwerte sind.
Obwohl das vorher aufschlagen müsste...

Also lesen und gib Dir Mühe und liefer ein MCVE.

PS Ich habe übrigens noch eine Variante geleifert, aber hast Du wohl nicht gelesen 
Wobei wir beim obigen Eingangssatz sind.