Per Makor Zeilen vervielfachen

Hallo,
habe mal wieder eine schwierige Aufgabe und ich hoffe, jemand kann mir helfen:
ich habe einen Datenbestand. Jeder Datensatz geht von Spalte A bis O. Anzahl der Datensätze kann immer unterschiedlich sein.
In der Spalte L habe ich einen String stehen. Der kann folgendermassen aussehen:
Teil1#Teil2#24,00;Teil3#Teil4#25,00;Teil5#Teil6#26,00;Teil7#Teil8#25,00;Teil9
Also, wie gesagt, ist nur ein Beispiel. Eventuell kann es auch mal vorkommen, dass es in der Spalte L mittendrin mal ein leeres Feld ginbt und dann weiter geht.
Ich möchte nun folgendes erreichen: ein Makro soll die Spalte L durchlaufen. Überall, wo in der Spalte L so ein String drin steht, soll geschaut werden, wie oft kommt das Zeichen SEMIKOLON vor.
Also in meinem Beispiel wäre das 4 mal das Zeichen SEMIKOLON.
Wenn in der Spalte L nun SEMIKOLONS gefunden werden, soll dieser entsprechende Datensatz nachher auch 4 mal da stehn, heisst, ich muss 3 mal kopier werden und unter den bestehenden Datensatz eingefügt werden.
Wenn das Makro zB 2 SEMIKOLONS finden würde, muss einmal das DS kopiert und eingefügt werden
Wenn das Makro zB 3 SEMIKOLONS finden würde, muss zweimal das DS kopiert und eingefügt werden
usw.
Im Prinzip muss ich nachher von meiner Anzahl an gefundenen Zeichen immer 1 abziehen und so oft vervielfältigen.
Ist das machbar mit einem Makro, würde mir viel Arbeit ersparen.
Danke schon mal für alle Tipps
Jockel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub test() Dim loletzte As Long Dim loa As Long Dim lob As Long Dim lAnzahl As Long Dim Text As String loletzte = Cells(Rows.Count, 12).End(xlUp).Row For loa = loletzte To 1 Step -1 Text = Cells(loa, 12) If InStr(Text, ";") > 0 Then For lob = 1 To Len(Text) If Mid(Text, lob, 1) = ";" Then lAnzahl = lAnzahl + 1 Next For lob = 1 To lAnzahl - 1 Rows(loa).Copy Rows(loa).Insert shift:=xlDown Next lAnzahl = 0 End If Next End Sub

Sub ZeilenKopieren() Dim rngRange As Range, lngErste As Long Dim AnzahlZeichen As Long With Tabelle1 'Tabelle anpassen Set rngRange = .Columns(12).Find(What:=";", LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False) If Not rngRange Is Nothing Then lngErste = rngRange.Row Do AnzahlZeichen = Count_Zeichen(rngRange.Value, ";") If AnzahlZeichen > 1 Then Call ZeilenInsert(rngRange, AnzahlZeichen - 1) Set rngRange = .Columns(12).Find(What:=";", After:=rngRange, LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False) Loop Until rngRange.Row >= lngErste Application.CutCopyMode = False End If End With End Sub Function Count_Zeichen(strText$, sZeichen$) As Long Count_Zeichen = Len(strText) - Len(Replace(strText, sZeichen, "")) End Function Sub ZeilenInsert(rngZelle As Range, lngAnzahl As Long) With Sheets(rngZelle.Parent.Name) rngZelle.EntireRow.Copy rngZelle.Offset(1, 0).Resize(lngAnzahl).EntireRow.Insert Shift:=xlDown End With End Sub

Sub Kopie() Dim i As Long, n As _ span> Long, lngLastRow As Long Dim varZähler As Variant With Application .ScreenUpdating = False .EnableEvents = False lngLastRow = Cells(Rows.Count, 12).End(xlUp).Row For i = lngLastRow To 1 Step -1 If InStr(Cells(i, 12), ";") _ Then For n = 1 To Len(Cells(i, 12)) _ If Mid(Cells(i, 12), n, 1) = ";" Then varZähler = varZähler + 1 End If Next End If If varZähler >= 2 Then Rows(i + 1).Resize(varZähler - 1).EntireRow.Insert Range(Cells(i, 1), Cells(i, 15)).Copy _ Range(Cells(i, 1), Cells(i + varZähler - 1, 15)) varZähler = 0 End If Next .ScreenUpdating = True .EnableEvents = True End With End Sub

Sub ZeilenKopieren() Dim rngRange As Range, lngErste As Long Dim AnzahlZeichen As Long With Tabelle1 'Tabelle anpassen Set rngRange = .Columns(12).Find(What:=";", LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False) If Not rngRange Is Nothing Then lngErste = rngRange.Row Do AnzahlZeichen = Count_Zeichen(rngRange.Value, ";") If AnzahlZeichen > 1 Then Call ZeilenInsert(rngRange, AnzahlZeichen) Set rngRange = .Columns(12).Find(What:=";", After:=rngRange, LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False) If rngRange Is Nothing Then Exit Do Loop Until rngRange.Row >= lngErste Application.CutCopyMode = False End If End With End Sub Function Count_Zeichen(strText$, sZeichen$) As Long Count_Zeichen = Len(strText) - Len(Replace(strText, sZeichen, "")) End Function Sub ZeilenInsert(ByVal rngZelle As Range, lngAnzahl As Long) Dim ArrayData With Sheets(rngZelle.Parent.Name) rngZelle.EntireRow.Copy rngZelle.Offset(1, 0).Resize(lngAnzahl).EntireRow.Insert Shift:=xlDown ArrayData = Split(rngZelle, ";") rngZelle.Resize(Ubound(ArrayData) + 1) = Application.Transpose(ArrayData) End With End Sub

Option Explicit Sub test() Dim loletzte As Long Dim loa As Long Dim lob As Long Dim lAnzahl As Long Dim sText Dim sInhalt1 Dim sInhalt2 loletzte = Cells(Rows.Count, 12).End(xlUp).Row For loa = loletzte To 1 Step -1 sInhalt1 = Range(Cells(loa, 1), Cells(loa, 11)) sInhalt2 = Range(Cells(loa, 13), Cells(loa, 15)) Range(Cells(loa, 1), Cells(loa, 11)).ClearContents If InStr(Cells(loa, 12), ";") > 0 Then sText = Split(Cells(loa, 12), ";") lAnzahl = UBound(sText) Cells(loa, 12) = sText(lAnzahl) For lob = lAnzahl - 1 To 0 Step -1 Rows(loa).Insert shift:=xlDown Cells(loa, 12) = sText(lob) Next sText = "" End If Range(Cells(loa, 1), Cells(loa, 11)) = sInhalt1 Range(Cells(loa, 13), Cells(loa, 15)) = sInhalt2 Next End Sub

Sub ZeilenKopieren() Dim rngRange As Range, lngErste As Long Dim AnzahlZeichen As Long With Tabelle1 'Tabelle anpassen Set rngRange = .Columns(12).Find(What:=";", LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False) If Not rngRange Is Nothing Then lngErste = rngRange.Row Do AnzahlZeichen = Count_Zeichen(rngRange.Value, ";") If AnzahlZeichen > 1 Then Call ZeilenInsert(rngRange, AnzahlZeichen - 1) Set rngRange = .Columns(12).Find(What:=";", After:=rngRange, LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False) If rngRange Is Nothing Then Exit Do Loop Until rngRange.Row >= lngErste Application.CutCopyMode = False End If End With End Sub Function Count_Zeichen(strText$, sZeichen$) As Long Count_Zeichen = Len(strText) - Len(Replace(strText, sZeichen, "")) End Function Sub ZeilenInsert(ByVal rngZelle As Range, lngAnzahl As Long) Dim ArrayData, strInhalt$ With Sheets(rngZelle.Parent.Name) strInhalt = Left$(rngZelle, InStrRev(rngZelle, ";") - 1) rngZelle.EntireRow.Copy rngZelle.Offset(1, 0).Resize(lngAnzahl).EntireRow.Insert Shift:=xlDown ArrayData = Split(strInhalt, ";") rngZelle.Resize(Ubound(ArrayData) + 1) = Application.Transpose(ArrayData) End With End Sub

Sub ZeilenKopieren() Dim rngRange As Range, lngErste As Long Dim AnzahlZeichen As Long With Tabelle1 'Tabelle anpassen Set rngRange = .Columns(12).Find(What:=";", LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False) If Not rngRange Is Nothing Then lngErste = rngRange.Row Do AnzahlZeichen = Count_Zeichen(rngRange.Value, ";") If AnzahlZeichen > 1 Then Call Teile_Entfernen(rngRange) Call ZeilenInsert(rngRange, AnzahlZeichen - 1) End If Set rngRange = .Columns(12).Find(What:=";", After:=rngRange, LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False) If rngRange Is Nothing Then Exit Do Loop Until rngRange.Row >= lngErste Application.CutCopyMode = False End If End With End Sub Function Count_Zeichen(strText$, sZeichen$) As Long Count_Zeichen = Len(strText) - Len(Replace(strText, sZeichen, "")) End Function Sub ZeilenInsert(ByVal rngZelle As Range, lngAnzahl As Long) Dim ArrayData With Sheets(rngZelle.Parent.Name) rngZelle.EntireRow.Copy rngZelle.Offset(1, 0).Resize(lngAnzahl).EntireRow.Insert Shift:=xlDown ArrayData = Split(rngZelle, ";") rngZelle.Resize(Ubound(ArrayData) + 1) = Application.Transpose(ArrayData) End With End Sub Sub Teile_Entfernen(rngZelle As Range) rngZelle = Left$(rngZelle, InStrRev(rngZelle, ";") - 1) End Sub

Hallo,
, vielleicht hilft es Dir den Code besser zu verstehen.

Sub ZeilenKopieren()
Dim rngRange As Range, lngErste As Long
Dim AnzahlZeichen As Long

'Tabelle anpassen 
With Tabelle1
    'erste Zelle von unten Suchen wo ; vorkommt 
    Set rngRange = .Columns(12).Find(What:=";", LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
    MatchCase:=False, SearchFormat:=False)
    'wurde was gefunden? 
    If Not rngRange Is Nothing Then
        'merke diese Zeile 
        lngErste = rngRange.Row
        'Do... Loop Schleife 
        Do
            'Anzahl ; Zählen über Funktion 
            AnzahlZeichen = Count_Zeichen(rngRange.Value, ";")
            'sind mehr als 1 ; vorhanden? 
            If AnzahlZeichen > 1 Then
                'letzten Teil abschneiden über die Sub 
                Call Teile_Entfernen(rngRange)
                'entsprechend viele Zeilen kopieren über Sub 
                Call ZeilenInsert(rngRange, AnzahlZeichen - 1)
            End If
            'Weiter Suchen ab der letzten fundstelle 
            Set rngRange = .Columns(12).Find(What:=";", After:=rngRange, LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
            MatchCase:=False, SearchFormat:=False)
            'nichts mehr gefunden aussteigen 
            If rngRange Is Nothing Then Exit Do
        'Schleife verlassen wenn Zeile >= erste Fundstelle ist 
        Loop Until rngRange.Row >= lngErste
        Application.CutCopyMode = False
    End If

End With

End Sub

Function Count_Zeichen(strText$, sZeichen$) As Long
    'entfernt ; und berechnet die Differenz der länge beider Strings 
    Count_Zeichen = Len(strText) - Len(Replace(strText, sZeichen, ""))
End Function

Sub ZeilenInsert(ByVal rngZelle As Range, lngAnzahl As Long)
Dim ArrayData
'Tabelle aus Zelle feststellen 
With Sheets(rngZelle.Parent.Name)
    'Zeile kopieren 
    rngZelle.EntireRow.Copy
    'entsprechend viele als kopie einfügen 
    rngZelle.Offset(1, 0).Resize(lngAnzahl).EntireRow.Insert Shift:=xlDown
    'Text aus Zelle in ein Array Splitten 
    ArrayData = Split(rngZelle, ";")
    'Zellebereich aus Array befüllen 
    rngZelle.Resize(Ubound(ArrayData) + 1) = Application.Transpose(ArrayData)
End With
End Sub

Sub Teile_Entfernen(rngZelle As Range)
    'InStrRev ; von hinten und gibt die pos. von vorn gezählt zurück 
    'mit Left entsprechend abschneiden 
    rngZelle = Left$(rngZelle, InStrRev(rngZelle, ";") - 1)
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread