Office: Brauche Hilfe bei Excel Macro

Hallo Leute,
und zwar habe ich eine Ecxel tabelle, welche aus mehreren anderen Programmen gespeist wird.
somit habe ich in einzelnen Zellen mehrere Einträge, welche durch ein Semikolon getrennt sind.
somit steht zum Beispiel in einer Zelle:

AGER123; AGER123; AGER123; AGER123; AGER123; AGER123

Das soll nun alles reduziert werden, so das insgesamt das Ergebnis nur einmal da steht.

Also:

AGER123

Am besten wäre die Lösung mit einem Macro, allerdings hab ich davon nicht viel Ahnung.
Ich habs mit diesem hier versucht, welches aber nicht bis auf einmal reduziert, sondern nur bis auf 2x.

Sub DoppelteWeg()
Dim strT As String
Dim strZ As String
Dim sCol As Collection
Dim sColZ As Variant
Dim intA As Integer
Dim intS As Integer
Dim intPos() As Integer
Dim rngZ As Range
On Error Resume Next
For Each rngZ In Selection.Cells
Set sCol = New Collection
strZ = rngZ.Value
intA = Len(strZ) - Len(Application.WorksheetFunction.Substitute(strZ, ";", ""))
ReDim intPos(0 To intA)
For intS = 1 To intA
intPos(intS) = InStr(intPos(intS - 1) + 1, strZ, ",")
Next intS
For intS = 1 To intA
strT = Mid(strZ, intPos(intS - 1) + 1, intPos(intS) - intPos(intS - 1) - 1)
sCol.Add strT, strT
strT = ""
Next intS
strT = Right(strZ, Len(strZ) - intPos(intA))
sCol.Add strT, strT
strZ = ""
For Each sColZ In sCol
strZ = strZ & sColZ & ";"
Next sColZ
strZ = Left(strZ, Len(strZ) - 1)
rngZ.Value = strZ
Set sCol = Nothing
Next rngZ
End Sub

Ich wäre euch sehr dankbar für Hilfe, da es eine sehr lange Liste ist und ich sonst ewig daran sitzen würde.

Gruß
Kasimir23

 

Hallo!

Brauchst du dafür nicht einfach nur alles hinter dem ersten Semikolon löschen?
=LINKS(A1;FINDEN(";";A1)-1)

 

aber schatzi das ist doch nur n beispiel.. was wenn nun aber von dem anderen programm her Ager123;Ager234;Ager123;Ager345.... kommt..

 

Na, das muss einem alten Mann doch gesagt werden!
Da fällt der Groschen halt nur noch pfennigweise...

Also soll aus
Ager123;Ager234;Ager123;Ager345
das hier werden:
Ager123;Ager234;Ager345
Oder wie?

Wenn dem so ist, dann hätte ich dies hier anzubieten:

Code:

Sub test()
Dim Zelle As Range
Dim DFeld As Variant
Dim Anzahl As Byte, i As Byte, j As Byte
  For Each Zelle In Selection
    DFeld = Split(Zelle.Text, ";")
    Anzahl = UBound(DFeld)
      For i = 0 To Anzahl
        If CStr(DFeld(i)) <> "" Then
          For j = i + 1 To Anzahl
            If CStr(DFeld(i)) = CStr(DFeld(j)) Then DFeld(j) = ""
          Next j
        End If
      Next i
    DFeld = CStr(Join(DFeld, ";"))
    Zelle = DFeld
      Do While InStr(Zelle, ";;") > 1
        Zelle.Replace What:=";;", Replacement:=";"
      Loop
    If Right(Zelle, 1) = ";" Then Zelle = Left(Zelle, Len(Zelle) - 1)
  Next Zelle
End Sub

Braucht bei mir für 1000 Zellen unter 10 sek und meine Kiste ist recht lahm...
Wahrscheinlich wrd's noch etwas fixer, wenn man während des Codes das ScreenUpdating abschaltet.

 

Ein Problem wäre da noch...

Erstmal Danke Schatzi das du so schnell geantwortet hast:)
Allerdings haut das noch nicht ganz so hin!
Wenn ich das ausführen will, makiert er mir diese Zeile:

Anzahl = UBound(DFeld)

Mit dem Hinweis: Überlauf

Ich hab leider keine Ahnung was mir das sagen soll^^
Auf jedenfall führt er das Makro halt deswegen nicht aus!
Hoffe du weißt auch hier rat:)

Gruß,
Kasimir

 

Hallo!

Sind deine einzelnen Datensätze denn viel länger als in deinem Beispiel?
Dann deklariere die Variablen Anzahl, i und j um: von Byte zu Integer.

Hilft das?

 

er meckert immer noch...

Also das längste was ich grade so gefunden hab in der Liste ist:

8192; 8192; 8192; 8192; 8192; 8192; 8192; 8192; 8192; 8192; 8192; 8192

und das alles in einer Zelle.

Manchmal sind die einzelnen Werte auch länger und bestehen aus buchstaben und zahlen (AGER12386392), dann stehen aber max. 6 durch Semikolon getrennte werte darin.

 

update

Habe grade nochmal mit einzelnen Spalten getestet...
da funktioniert es meistens, allerdings macht er dann aus:
AGER00319897; AGER00319897; AGER00319897; AGER00319897; AGER00319897

immernoch:
AGER00319897; AGER00319897

Also er kürzt das ganze nicht auf einen wert!

Und wenn ich es auf die ganze Mappe anwende, meckert er immer noch mit einem Laufzeitfehler und zwar wiederrum an der Zeile

Anzahl = UBound(DFeld)

Ich hoffe ich strapazier deine Nerven nicht zu sehr, aber danke das du mir hilfst!:)

 

Hallo!

Der Fehler scheint bei Leerzellen aufzutauchen.
Probier mal diesen Code:

Code:

Sub test()
Dim Zelle As Range
Dim DFeld As Variant
Dim Anzahl As Byte, i As Byte, j As Byte
  For Each Zelle In Selection
    If Zelle <> "" Then
    DFeld = Split(Zelle.Text, ";")
    Anzahl = UBound(DFeld)
      For i = 0 To Anzahl
        If CStr(DFeld(i)) <> "" Then
          For j = i + 1 To Anzahl
            If CStr(DFeld(i)) = CStr(DFeld(j)) Then DFeld(j) = ""
          Next j
        End If
      Next i
    DFeld = CStr(Join(DFeld, ";"))
    Zelle = DFeld
      Do While InStr(Zelle, ";;") > 1
        Zelle.Replace What:=";;", Replacement:=";"
      Loop
    If Right(Zelle, 1) = ";" Then Zelle = Left(Zelle, Len(Zelle) - 1)
    End If
  Next Zelle
End Sub

Bei deinem Beispiel sieht es so aus, als wären die einzelnen Teile durch ein Semikolon UND ein Leerzeichen getrennt. Wenn dem so ist, dann passe dies in dieser Zeile an:

Code:

DFeld = Split(Zelle.Text, ";")

 

Das funzt ja schon mal super, aber..

Super sache, das fuktioniert erstmal schon.
Nun ist aber noch eine letzte kleinigkeit!

Also ich könnte auch 2 Makros machen, indem das eine in der Zeile:

DFeld = Split(Zelle.Text, ";")

und das andere in der Zeile:

DFeld = Split(Zelle.Text, "; ")

Also einmal mit und einmal ohne Leerzeichen!
Denn mir is aufgefallen, das es manche Zellen gibt, in denen
AGER123;AGER546; AGER123;AGER546; AGER123

steht.
Also einmal mit und einmal ohne Leerzeichen dazwischen..ist es auch möglich beide befehle in das MAkro zu bekommen?
HAb grade son bissle rumversucht, aber das irgendwie nicht hinbekommn^^

 

Hallo!

Füge mal hinter dieser Zeile

Code:

If Zelle <> "" Then

diese Zeile ein

Code:

Zelle = Application.WorksheetFunction.Substitute(Zelle, "; ", ";")

Damit wandelst du schon im Vorwege alle "Semikolon+Leer" in "Semikolon" um.

PS: Was wird dir denn da für ein besch... Datenimport vorgesetzt?
Da würde ich doch

 

hey ho schatzi

also ich habe das grade mal getestet...
leider macht er jetzt irgendwie nix mehr..also er führt das makro zwar aus, aber es bringt nichts mehr^^

also er löscht nun nicht mehr mehrfache einträge....

hatte das ja grade mit 2 makros gelöst, das hat sogar toll geklappt, bis auf bei ein paar einträgen...wo am anfang der zelle ein blank ist^^

Frag mich nich, der import ist echt mal nicht der beste....einfach zu häufige abweichungen....es gibt nun also 3 sachen..einmal ";"...dann noch " ;" und dann noch "; "...ich dreh auch langsam durch... :-?

 

Hallo!

Wenn er jetzt nichts tut, dann hast du wahrscheinlich in dieser Zeile immer noch das Leerzeichen hinten dran:

Code:

DFeld = Split(Zelle.Text, ";")

 

huhu

jetzt sagt er immmer end if ohne if block!

meine Zeile wo erst:
If Zelle <> "" Then

stand, sieht jetzt so aus:

If Zelle <> "" Then Zelle = Application.WorksheetFunction.Substitute(Zelle, "; ", ";")

und nun sagt er immer end if, ohne if block!

langsam is es nicht mehr lustig, oder?:)

Aber voll nett von dir das du trotzdem noch weiter hilfst!:)

 

Nein, die Zeile darf nicht daHINTER, sondern daRUNTER!
Und um die Fälle "Leer+Semikolon" auch noch auszuschließen, machen wir noch 'ne Zeile dazu:

Code:

Sub test()
Dim Zelle As Range
Dim DFeld As Variant
Dim Anzahl As Byte, i As Byte, j As Byte
  For Each Zelle In Selection
    If Zelle <> "" Then
    Zelle = Application.WorksheetFunction.Substitute(Zelle, "; ", ";")
    Zelle = Application.WorksheetFunction.Substitute(Zelle, " ;", ";")
    DFeld = Split(Zelle.Text, ";")
    Anzahl = UBound(DFeld)
      For i = 0 To Anzahl
        If CStr(DFeld(i)) <> "" Then
          For j = i + 1 To Anzahl
            If CStr(DFeld(i)) = CStr(DFeld(j)) Then DFeld(j) = ""
          Next j
        End If
      Next i
    DFeld = CStr(Join(DFeld, ";"))
    Zelle = DFeld
      Do While InStr(Zelle, ";;") > 1
        Zelle.Replace What:=";;", Replacement:=";"
      Loop
    If Right(Zelle, 1) = ";" Then Zelle = Left(Zelle, Len(Zelle) - 1)
    End If
  Next Zelle
End Sub

Und wenn's jetzt nicht funktioniert, dann