Zeilen so oft duplizieren wie in Zelle steht

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Marc,
machst dir ein kleines Script für:

Sub MultipiziereZeileMenge()
Dim lRow As Long
Dim lRow2 As Long
Dim rFor As Range
Dim iAnz As Integer
Dim wksEingabe As Worksheet
Dim wksAusgabe As Worksheet
'In deiner Tabelle heissen die Seiten sicher nicht "Tabelle1" und "2"?
Set wksEingabe = Sheets("Tabelle1")     'Tabellenname hier ÄNDERN!
Set wksAusgabe = Sheets("Tabelle2")     'Tabellenname hier ÄNDERN!
lRow2 = wksAusgabe.Range("A65000").End(xlUp).Row    'letzte Zeile im Ausgabeblatt
With wksEingabe
lRow = .Range("D1").End(xlDown).Row                 'letzte Zeile im Eingabeblatt
For Each rFor In .Range("D2:D" & lRow)              'für jede Zeile im Eingabeblatt
rFor.EntireRow.Copy                             'kopiere sie
For lanz = 1 To rFor.Value                      'und füge die X-Mal
lRow2 = lRow2 + 1                           'in die letzte Zeile des Ausgabeblattes
wksAusgabe.Range("A" & lRow2).PasteSpecial  'ein
Next lanz
Next rFor
End With
End Sub

Ich nehme an, es werden nur Werte kopiert und keine Formeln. Desweitern nehme ich an, dass unter und neben den Tabellen nichts weiter steht und dass eine Beispieldatei im Aufbau genau deiner echten Datei entspricht.
Grüße,
Klaus M.vdT.

Hallo NoNet und Rudi,
Aus akademischem Interesse: Wie prüfe ich denn die letzte Zeile immer eindeutig?
mein sehr theoretisches Konstrukt: A1:A100 sind mit Text gefüllt. A99:A100.EntireRow ist ausgeblendet (und soll es auch bleiben). Die beiden Zellen A99 und A100 sind natürlich verbunden. Zusätzlich liegt über A1:A99 ein Autofilter, der nur Zeile 98 ausfiltert. Die UsedRange geht bis Zeile 10.000, weil ein Depp in Zelle B10000 was geschrieben hat. (Hab ich irgendwas vergessen?)
Um hier zuverlässig die letzte Zeile zu finden, müsste ich ja ungefähr so vorgehen:
For lZellen = 1 to 1048576 step -1
if Range("A" & lZellen) = "" then
lRow = lZellen
else
exit for
next lZellen
Aber das kann ja nicht richtig sein!
Gibts dafür eine "richtige" elegante Lösung?
Grüße,
Klaus M.vdT.

Sub ZeilenProMengeKopieren() Dim wsQ As Worksheet, wsZ As Worksheet, lngZ As Long, lngZ2 As Long Set wsQ = Worksheets("Tabelle1") Set wsZ = Worksheets("Tabelle3") wsQ.Rows(1).Copy wsZ.[A1] 'Überschriftenzeile kopieren lngZ2 = 2 For lngZ = 2 To wsQ.Cells(Rows.Count, 1).End(xlUp).Row wsQ.Rows(lngZ).Copy wsZ.Rows(lngZ2).Resize(wsQ.Cells(lngZ, 4)) lngZ2 = lngZ2 + wsQ.Cells(lngZ, 4) Next End Sub

Dim i As Long Dim a As Long a = 2 With Worksheets("Tabelle1") For i = 2 To .Cells(.Rows.Count, 4).End(xlUp).Row Worksheets("Tabelle3").Cells(a, 1).Resize(.Cells(i, 4), 8).Value = .Cells(i, 1). _ Resize(1, 8).Value a = a + .Cells(i, 4) Next End With

Sub Messung() Range("A1:A1048576").FormulaR1C1 = "=RAND()" t = Timer Range("A1").EntireColumn.Copy Range("B1").PasteSpecial xlPasteValues Debug.Print "CopyPaste: " & Timer - t t = Timer Range("C1").EntireColumn.Value = Range("A1").EntireColumn.Value Debug.Print ".value.value: " & Timer - t End Sub

Option Explicit Sub Marc() Dim x&, Dupl& Dim Loletzte& Loletzte = Tabelle3.Cells(Rows.Count, 1).End(xlUp).Row For x = 3 To 2 Step -1 Dupl = Tabelle1.Cells(x, 4) Tabelle1.Rows(x).Copy Tabelle3.Rows(Loletzte + 1 & ":" & Dupl + 1).Insert Shift:=xlDown Next Application.CutCopyMode = xlCut End Sub

Beliebteste Forumthreads (12 Monate)

Zeilen so oft duplizieren wie in Zelle steht

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen so oft duplizieren wie in Zelle steht

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread