VBA: Zeile auswählen, kopieren und x-fach einfügen

Hallo zusammen

ich stehe an und brauche Hilfe...
Ausgangslage: Ich mach die Einsatzplanung für einen Anlass. Die Bereichsleiter haben mir ihren Personalbedarf gemeldet: Pro Einsatzart eine Zeile, jedoch kann jeder Einsatz auch mehrere Personen benötigen (Spalte E "Anz. Personen").
Aufgabe: Ich muss für jede Person eine einzelne Zeile bekommen (Kopieren und Einfügen). Somit muss jede Zeile geprüft werden, welche Anzahl drin steht und wenn >1 dann muss die Zeile kopiert und entsprechend häufig eingefügt werden.
Ziel: ein VBA-Script, dass ich nach jeder Aktualisierung*) ausführen kann

*) immer basierend von der Originaldatei, die noch laufend angepasst wird. Der Script läuft dann immer auf einer Kopie.

Die Musterdatei ist gekürzt, Original deutlich umfangreicher (ca. 400 Zeilen)
https://www.herber.de/bbs/user/165754.xlsm

Vielen Dank für die Unterstützung!
Roman

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Einfuegen() Dim lngZeile As Long Dim lngAnzahl As Long For lngZeile = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1 If Cells(lngZeile, 5) > 1 Then lngAnzahl = Cells(lngZeile, 5) Range(Cells(lngZeile + 1, 1), Cells(lngZeile + lngAnzahl - 1, 1)).EntireRow.Insert Range(Cells(lngZeile, 1), Cells(lngZeile, 17)).Copy Range(Cells(lngZeile + 1, 1), Cells(lngZeile + lngAnzahl - 1, 1)) End If Next lngZeile End Sub

Moin
Sollte passen.

Sub Einfuegen()

    Dim lngZeile As Long, lngAnzahl As Long, zaehler As Long

    Dim Zelle As Range

    Application.ScreenUpdating = False

    For lngZeile = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1

        If Cells(lngZeile, 5) > 1 Then

          zaehler = 1

            lngAnzahl = Cells(lngZeile, 5)

            Range(Cells(lngZeile + 1, 1), Cells(lngZeile + lngAnzahl - 1, 1)).EntireRow.Insert

            Range(Cells(lngZeile, 1), Cells(lngZeile, 17)).Copy Range(Cells(lngZeile + 1, 1), Cells(lngZeile + lngAnzahl - 1, 1))

            Range(Cells(lngZeile, 5), Cells(lngZeile + lngAnzahl - 1, 5)) = 1

              For Each Zelle In Range(Cells(lngZeile, 15), Cells(lngZeile + lngAnzahl - 1, 15))

                Zelle = Left(Zelle, InStr(1, Zelle, "x")) & zaehler

                  zaehler = zaehler + 1

              Next

        End If

    Next lngZeile

End Sub

gruss hary

Sub Einfuegen() Dim lngZeile As Long, lngAnzahl As Long, zaehler As Long Dim Zelle As Range Application.ScreenUpdating = False For lngZeile = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If Cells(lngZeile, 5) > 1 Then zaehler = 1 lngAnzahl = Cells(lngZeile, 5) Range(Cells(lngZeile + 1, 1), Cells(lngZeile + lngAnzahl - 1, 1)).EntireRow.Insert Range(Cells(lngZeile, 1), Cells(lngZeile, 17)).Copy Range(Cells(lngZeile + 1, 1), Cells(lngZeile + lngAnzahl - 1, 1)) Range(Cells(lngZeile, 5), Cells(lngZeile + lngAnzahl - 1, 5)) = 1 For Each Zelle In Range(Cells(lngZeile, 15), Cells(lngZeile + lngAnzahl - 1, 15)) Zelle = Zelle & "-" & zaehler zaehler = zaehler + 1 Next End If Next lngZeile End Sub

Sub Einfuegen() Dim lngZeile As Long Dim lngAnzahl As Long Dim strID As String Dim lngZiel As Long Dim lngZaehler As Long For lngZeile = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If Cells(lngZeile, 5) > 1 Then lngAnzahl = Cells(lngZeile, 5) Range(Cells(lngZeile + 1, 1), Cells(lngZeile + lngAnzahl - 1, 1)).EntireRow.Insert Range(Cells(lngZeile, 1), Cells(lngZeile, 17)).Copy Range(Cells(lngZeile + 1, 1), Cells(lngZeile + lngAnzahl - 1, 1)) For lngZiel = lngZeile To lngZeile + lngAnzahl - 1 lngZaehler = lngZaehler + 1 Cells(lngZiel, 15) = Cells(lngZiel, 15) & "-" & lngZaehler Next lngZiel lngZaehler = 0 End If Next lngZeile End Sub

Beliebteste Forumthreads (12 Monate)

VBA: Zeile auswählen, kopieren und x-fach einfügen

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Zeile auswählen, kopieren und x-fach einfügen

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread