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
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)
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
@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
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 …
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
Hallo, :19:
mache eine aussagekräftige Beispieldatei und lade sie hier hoch - dann schaut schon einer von uns drüber. :21:
(07.09.2019, 13:45)Case schrieb: [ -> ]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.....
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.