Zeile duplizieren

Hi,
vor einigen Tagen habe ich von einem VBA-Experten bei einer Aufgabe Hilfe bekommen, worüber ich sehr dankar bin!
Das Makro habe ich an meine Bedürfnisse angepasst. Allerdings muss noch eine Aktion hinzugefügt werden, an der ich momentan scheiter...
Im Anhang findet Ihr mehrerer Dateien, die für mein Vorhaben benötigt werden.
Die Dateien Master.xlsx und Slave.xlsx werden mit der Datei MakroDatei.xlsm zusammengefügt und in der Datei Neu.xlsx abgespeichert.
In der Datei Neu.xlsx findet man in Spalte D Tätigkeiten denen Bedarfe in Spalte E zugewiesen sind. ( Tätigkeit_1 hat 3 Bedarfe)
Mein Ziel ist, die Tätigkeiten mit Bedarfen größer 1 zu splitten und untereinander in der Datei Neu.xlsx abzubilden. Eine Beispiel des Endzustands findet Ihr in der Datei Neu.xlsx, Tabellenblatt SOLL.
Einen theoretischen Ansatz habe ich (Nach Bedarf suchen, Zeile kopieren und anschließend einfügen), bekomme ihn aber nicht in das bestehende Mako, Datei MakroDatei.xlsm, eingebaut.
Könnt Ihr mir bitte noch einmal helfen ? :(
Vorgehensweise:
Die Master und Slave Datei müssen in einem Ordner abgelegt werden. In der MakroDatei.xlsm muss der Pfad hinterlegt werden...
Dateien:
MakroDatei: https://www.herber.de/bbs/user/102755.xlsm
Master-Datei: https://www.herber.de/bbs/user/102756.xlsx
Slave-Datei: https://www.herber.de/bbs/user/102757.xlsx
Ergbenis-Datei: https://www.herber.de/bbs/user/102758.xlsx
Viele Grüße!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Björn
ich habe das Dublizieren der Zeilen noch davorgeschaltet. Nachteil, alle Zeilen werden 2x durchlaufen.
In deinem Beispiel hast du aber

112273240	Name_2	Unternehmen_1	Tätigkeit_2	2

vergessen oder?


Sub SlaveMaster()
On Error GoTo Fehler
Dim LR&, Pfad$, Quelle$, Slave$, i&, Tmp%
Dim Bed%
Pfad = "C:\Users\Björn\Desktop\Makro\"
Quelle = "[Master.xlsx]Tabelle1"
Slave = Pfad & "Slave.xlsx"
Application.ScreenUpdating = False
Workbooks.Open Filename:=Slave
With ActiveSheet
LR = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte A
.Columns("B:C").Insert Shift:=xlToRight
.Range("B1:C" & LR).FormulaR1C1 = _
"=VLOOKUP(RC1,'" & Pfad & Quelle & "'!C1:C3,COLUMN(),0)"
.Columns("B:C").Copy
.Columns("B:C").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
.Columns("B:C").EntireColumn.AutoFit
For i = LR To 2 Step -1
Bed = .Cells(i, 5) 'Anzahl Wiederholungen
If Bed > 1 Then
.Cells(i, 5) = 1
.Rows(i).Copy
.Rows(i + 1 & ":" & i + Bed - 1).Insert Shift:=xlDown
Application.CutCopyMode = False
End If
Next
LR = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte A
For i = 2 To LR
Tmp = i + 1
Do Until .Cells(Tmp, 1)  .Cells(i, 1)
Tmp = Tmp + 1
Loop
If Tmp  i + 1 Then
.Range(Cells(i + 1, 1), Cells(Tmp - 1, 3)).ClearContents
i = Tmp - 1
End If
Next
End With
ActiveWorkbook.SaveAs Filename:=Pfad & "Neu.xlsx"
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Gruß UweD

Aufsplitten_der_Aufträge_Click() lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row For i = lastrow To 2 Step -1 If Cells(i, 5).Value > 1 Then Rows(i).Select For ins = 2 To Cells(i, 5).Value Selection.Copy Selection.Insert Shift:=xlDown Application.CutCopyMode = False Next ins Range(Cells(i, 5), Cells(i + ins - 2, 5)).Value = 1 Range(Cells(i, 6), Cells(i + ins, 6)).Value = beispiel End If Next i

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread