Excel VBA WENN-Funktion

[Lassylver]

Hallo zusammen,

ich scheitere schon einige Zeit daran ein Makro zu programmieren, welches mir folgendes Problem lösen sollte - ich habe eine riesige Datenmenge und darin eine Spalte, sagen wir mal Spalte A, nach der nach folgendem gesucht werden soll:

Sollte in der Zelle zwei oder mehrere Datenwerte stehen (zB 180006654654 18213213212 180007113), sollte die WENN-Funktion die gesamte Zeile kopieren und darunter einfügen (Anzahl der kopierten Zeilen = Anzahl der Datenwerte, zB 3 Datenwerte = 3 Zeilen) und gleichzeitig sicherstellen, dass pro Zeile in der besagten Zelle nur noch 1 Datenwert steht. Der Rest der Zeile sollte gleich bleiben.
Endresultat: Wenn ich vorher eine Zeile hatte mit 3 Werten in Zelle A1, habe ich danach 3 Zeilen mit jeweils einem der Werte in Zelle A1, A2, A3).
Sollte in der Zelle nur ein Datenwert stehen (zB 180002695974), sollte die WENN-Funktion gar nichts machen.

Wäre echt froh, wenn mir jemand helfen könnte!!!

Danke,
Lassylver

 

[Snooty]

Kannst du dazu mal eine Beispieltabelle zeigen? Kann mir gerade nicht vorstellen, wie deine Daten vorher und nachher aussehen sollen.

 

[Alchemist]

Ist die Reihenfolge entscheidend?
Also, wenn in einer Zelle mehrere Werte stehen, müssen die dann zwingend auch an dieser Stelle eingefügt werden?

Wie sind die Daten in einer Zelle getrennt? Leerzeichen, etc.?

 

[Lassylver]

Hallo, anbei ein Vorher-Nachher Beispiel meiner Tabelle:

Vorher:

Die rot markierten Zellen in Spalte D enthalten mehrere Werte, diese müssen aufgeteilt werden.

Nachher:

In Spalte D ist nun jeder Wert nur einmal, der Rest der Zeile ist Copy-Paste von der Original Zeile.

Die Werte in der betroffenen Zelle sind "normalerweise" mit zwei Leerzeichen getrennt (Normalfall) Kann aber auch passieren, dass es nur ein Leerzeichen ist.

@Alchemist: Bzgl. der Frage mit der Reihenfolge ist mir nicht ganz klar was du meinst!

 

[Alchemist]

Tada

Sub Makro1()
'
' Makro1 Makro
'
Application.ScreenUpdating = False
'
Dim zellstring As String
Dim stringneu As String

'Doppelleerzeichen durch ein einfaches ersetzen
For i = 1 To 5
    Columns("D:D").Select
    Selection.Replace What:="  ", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
Next i

'Grenze anpassen falls nötig, muss deutlich mehr sein als Anzahl der aktuellen Zeilen!
For i = 2 To 1000000
    zellstring = Cells(i, 4)

'Wenn Leerzeichen enthalten
    If CountChar(zellstring, " ") > 0 Then
        Cells(i, 4) = Left(zellstring, InStr(zellstring, " ")) 'Wert in D (Spalte 4) ersetzen durch alles vorm Leerzeichen
        Rows(i).Copy 'Zeile kopieren
        Rows(i).Insert shift:=xlDown 'Zeile unterhalb einfügen
        Cells(i + 1, 4) = Mid(zellstring, InStr(zellstring, " ") + 1) 'Wert in D durch alles rechts vom Leerzeichen ersetzen
    End If

If Cells(i, 1) = "" Then Exit For 'Wenn keine weiteren Werte in Spalte A stehen wird abgebrochen.

Next i
Application.ScreenUpdating = True
End Sub


Function CountChar(ByVal SourceString As String, ByVal strChar As String) As Integer
   CountChar = Len(SourceString) - Len(Replace(SourceString, strChar, ""))
End Function

 

[cumulonimbus8]

Tada? Wie wär's mit InStr statt der Function, und Mid um das Copy (was die Zwischenablage killt) zu umschiffen? O:-)
CN8

 

[Lassylver]

@Alchemist: Vielen, vielen lieben DANK!!! Funktioniert grossartig! :-) Ich kann gar nicht sagen, wie happy ich gerade bin, nach den vielen Stunden, die ich da verbracht habe, dass es nun doch endlich funktioniert, so wie ich möchte!!! DANKE!!!!!

@cumulonimbus8: Was meinst du genau mit Mid um das Copy zu umschiffen?

 

[Alchemist]

Immer gern!
Ich hatte ursprünglich mal was anderes geschrieben. was CN8 meint, ist dass die Funktion eigentlich nicht nötig ist.
Der Code hier funktioniert genauso. Du kannst aber einfach bei dem bleiben, was du jetzt hast. Ich poste es nur der Vollständigkeit halber.
Was genau hier die Zwischenablage für ein Problem bekommen soll, ist mir aber auch ein Rätsel. Die Zeile muss ja eh kopiert werden.

Sub Makro1()
'
' Makro1 Makro
'
Application.ScreenUpdating = False
'
Dim zellstring As String
Dim stringneu As String

'Doppelleerzeichen durch ein einfaches ersetzen
For i = 1 To 5
    Columns("D:D").Select
    Selection.Replace What:="  ", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
Next i

'Grenze anpassen falls nötig, muss deutlich mehr sein als Anzahl der aktuellen Zeilen!
For i = 2 To 1000000
    zellstring = Cells(i, 4)

'Wenn Leerzeichen enthalten
    If InStr(zellstring, " ") > 0 Then
        Cells(i, 4) = Left(zellstring, InStr(zellstring, " ")) 'Wert in D (Spalte 4) ersetzen durch alles vorm Leerzeichen
        Rows(i).Copy 'Zeile kopieren
        Rows(i).Insert shift:=xlDown 'Zeile unterhalb einfügen
        Cells(i + 1, 4) = Mid(zellstring, InStr(zellstring, " ") + 1) 'Wert in D durch alles rechts vom Leerzeichen ersetzen
    End If

If Cells(i, 1) = "" Then Exit For 'Wenn keine weiteren Werte in Spalte A stehen wird abgebrochen.

Next i
Application.ScreenUpdating = True
End Sub

 

[cumulonimbus8]

Was meinst du genau mit Mid um das Copy zu umschiffen?

Ich meine damit: ich kann per INSTR die Trennleerstelle finden. Damit erlange ich Koordinate um über MID gezielt Textstücke zu erfassen und per Variable ans Ziel bringen - ohne den Inhalt der Zwischenablage zu verändern. Dies in mehreren Schritten.
Das ist eine Macke von mir, die aber schon sehr oft sehr nützlich war.

CN8

 

[Lassylver]

@cumulonimbus8 Ah, verstanden!
@Alchemist : Nochmals vielen, vielen lieben Dank, beide Varianten funktionieren!

Lassylver