Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1692to1696
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Vermehren von Zeilen auf Basis eines Zellwertes

Vermehren von Zeilen auf Basis eines Zellwertes
23.05.2019 10:38:12
Zeilen
Hallo liebe Excelfreunde,
ich hoffe ich kann auf diesem Wege Hilfe bekommen. Ich habe ordentlich gesucht, aber keine hilfreichen Themen hier im Forum gefunden.
In Tabellenblatt 1 in der Spalte A1 bis A30 sind jeweils eine Artikelnummer eingetragen und in den anderen Spalten Daten dazu (das ist unwichtig). In einem anderen Tabellenblatt 2 sind auch wieder diese Artikelnummern eingetragen aber zusätzlich in Spalte B zwei jeweils eine Zahl (1-30). Beispieldatei ist angehängt.
Ich benötige eine Funktion, die in Tabellenblatt 2 die Artikelnummern nacheinander durchgeht. Sie nimmt die erste Artikelnummer, sucht diese in Tabellenblatt 1 und vermehrt die Zeile (kopieren und einfügen) genau so oft wie die zugehörtige Anzahl in Spalte B im Tabellenblatt 2. Danach wieder wie eben, aber mit dem zweiten Artikel in A2 aus dem Tabellenblatt 2.
https://www.herber.de/bbs/user/129980.xlsx
Ich hoffe ich konnte es verständlich erläutern und ihr könnt mir helfen.
Natürlich gerne einfach fragen, wenn etwas unklar ist.
Vielen herzlichen Dank im voraus!!
Gruß Thomas

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Vermehren von Zeilen auf Basis eines Zellwertes
23.05.2019 11:04:06
Zeilen
Hallo Thomas,
so:
Public Sub aaa()
Dim loLetzte As Long, i As Long, raFund As Range
Application.ScreenUpdating = False
With Worksheets("Tabelle2")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To loLetzte
Set raFund = Worksheets("Tabelle1").Columns(1).Find(what:=.Cells(i, 1), LookIn:= _
xlValues, Lookat:=xlWhole)
If Not raFund Is Nothing Then
Worksheets("Tabelle1").Rows(raFund.Row).Copy
Worksheets("Tabelle1").Rows(raFund.Row + 1).Resize(.Cells(i, 2)).Insert
End If
Next i
End With
Application.CutCopyMode = False
End Sub
Gruß Werner
Anzeige
AW: Vermehren von Zeilen auf Basis eines Zellwertes
23.05.2019 11:11:26
Zeilen
Wahnsinn!
Das ist großartig. Danke Werner!
Hab noch einen schönen Tag.
Gruß Thomas
So, wo kann ich jetzt Werner die 5 Sterne Bewertung geben?
AW: Vermehren von Zeilen auf Basis eines Zellwertes
23.05.2019 11:15:45
Zeilen
Oh, ich habe noch eine kleine Frage. Wenn ich in Tabellenblatt 2 als Anzahl einmal die Null habe, dann geht es natürlich nicht. Das ist logisch. Dann bricht die Funktion ab. Ist es möglich dann einfach zu skippen?
AW: Vermehren von Zeilen auf Basis eines Zellwertes
23.05.2019 12:33:32
Zeilen
Hallo Thomas,
dann so:
Public Sub aaa()
Dim loLetzte As Long, i As Long, raFund As Range
Application.ScreenUpdating = False
With Worksheets("Tabelle2")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To loLetzte
If .Cells(i, 2) > 0 Then
Set raFund = Worksheets("Tabelle1").Columns(1).Find(what:=.Cells(i, 1), _
LookIn:=xlValues, Lookat:=xlWhole)
If Not raFund Is Nothing Then
Worksheets("Tabelle1").Rows(raFund.Row).Copy
Worksheets("Tabelle1").Rows(raFund.Row + 1).Resize(.Cells(i, 2)).Insert
End If
End If
Next i
End With
Application.CutCopyMode = False
Set raFund = Nothing
End Sub
Gruß Werner
Anzeige
noch eine Änderung
23.05.2019 13:59:38
Werner
Hallo Thomas,
hier noch zusätzlich noch mit einer Prüfung ob es sich in Spalte B auch um eine Zahl handelt. Ansonsten würde das Makro in einen Fehler laufen, falls dort mal versehentlich ein Text rein gerutscht sein sollte.
Public Sub aaa()
Dim loLetzte As Long, i As Long, raFund As Range
Application.ScreenUpdating = False
With Worksheets("Tabelle2")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To loLetzte
If IsNumeric(.Cells(i, 2)) And .Cells(i, 2) > 0 Then
Set raFund = Worksheets("Tabelle1").Columns(1).Find(what:=.Cells(i, 1), _
LookIn:=xlValues, Lookat:=xlWhole)
If Not raFund Is Nothing Then
Worksheets("Tabelle1").Rows(raFund.Row).Copy
Worksheets("Tabelle1").Rows(raFund.Row + 1).Resize(.Cells(i, 2)).Insert
End If
End If
Next i
End With
Application.CutCopyMode = False
Set raFund = Nothing
End Sub
Gruß Werner
Anzeige
AW: noch eine Änderung
23.05.2019 15:55:46
Thomas
Du bist klasse. 1000 Dank!
Das hilft mir wahnsinnig weiter.
Gruß Thomas
Gerne u. Danke für die Rückmeldung. o.w.T.
23.05.2019 16:10:28
Werner

311 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige