Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Kopieren von Zeilen abhängig von Anzahl Zeilen

Kopieren von Zeilen abhängig von Anzahl Zeilen
10.01.2018 19:32:30
Zeilen
Hallo liebes Forum,
ich möchte mit VBA abhängig von der Anzahl an eingetragenen IPC Klassen in Spalte B jede Zeile abhängig von der Anzahl an IPC Klassen (Spalte F) kopieren (e.g. Zeile 4 soll 5 mal kopiert werden, da sie in Spalte B 5 IPC Klassen enthält).
Ziel ist es also, am Ende jede Zeile entsprechend ihrer Anzahl an IPC Klassen (Spalte F) häufig zu kopieren, dafür aber mit einer einzigen IPC Klasse in der Tabelle zu haben. Aus der Ursprungszeile sollen demnach die IPC Klassen aus Spalte B die auf die kopierten Zeilen verteilt wurden, gelöscht werden.
(Im Falle von 4 IPC Klassen sollte die Zeile analog 4 mal kopiert werden und die IPC Klassen spezifisch auf diese 4 Kopien verteilt werden).
Userbild
Ich hoffe, es ist verständlich was ich umsetzen möchte.
Ich hatte bereits von einigen Wochen eine ähnliche Fragestellung bei der mir bereits Franz, Werner und Sepp geholfen haben - hier gab es allerdings den Zwischenschritt, dass ich die einzelnen Zeilen vorsortiert hatte auf verschiedene Sheets, abhängig von der Anzahl an IPC Klassen. Da ich mir ziemlich sicher bin, dass man sich diesen Zwischenschritt sparen kann, poste ich das Problem nochmal hoffnungsvoll ins Forum.
Dies hier war jedenfalls der Code zum Kopieren der Zeilen und spezifischen Verteilen der IPC codes (von Franz): (den ich bereits versucht habe soweit mir möglich / verständlich anzupassen)
Ich danke euch!!
Rahel
Sub Test2()
Dim lngIndex As Long, lngLastRow As Long, lngNext As Long
Dim J As Integer, AnzIPC As Integer, Spalte As Long, StatusCalc As Long
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For lngIndex = lngLastRow To 2 Step -1
AnzIPC = .Cells(lngIndex, 6).Value 'berechnete Anzahl IPC in Spalte P
Select Case AnzIPC
Case 0 To 1
'do nothing
Case Else
.Range(.Rows(lngIndex + 1), .Rows(lngIndex + AnzIPC - 1)).Insert
.Rows(lngIndex).Copy Destination:=.Range(.Rows(lngIndex + 1), .Rows( _
lngIndex + AnzIPC - 1))
Spalte = 6
For J = 2 To AnzIPC
Spalte = Spalte + 1
.Cells(lngIndex + J - 1, 6).Value = .Cells(lngIndex, Spalte).Value
Next
End Select
Next
lngLastRow = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
.Range(.Cells(2, 7), .Cells(lngLastRow, 15)).ClearContents
End If
End With
Next
With Application
.Calculation = StatusCalc
.ScreenUpdating = True
End With
End Sub

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
mal nur als ersten Ansatz ...
10.01.2018 23:37:57
Matthias
Hallo
Benutze eine Schleife
Den Schleifenzähler kannst Du per Formel ermitteln
Ausgehend davon das es in jedem IPC einen "/" gibt.
Formel:
=LÄNGE(B2)-LÄNGE(WECHSELN(B2;"/";""))
VBA:
LEN(B2)-LEN(SUBSTITUTE(B2,"/",""))
wobei Du B2 als Range angeben musst oder als Cells(zeile,Spalte)
und vor SUBSTITUTE noch die Funktionsapplikation stehen sollte.
Gruß Matthias
AW: mal nur als ersten Ansatz ...
11.01.2018 00:30:02
Rahel
Hi Matthias,
danke dir! Aber das habe ich doch sogar tatsächlich schon berücksichtigt - die Anzahl der IPC Klassen stehen ja bereits in Spalte F - das habe ich in den Code versucht einzubauen:
For lngIndex = lngLastRow To 2 Step -1
AnzIPC = .Cells(lngIndex, 6).Value 'berechnete Anzahl IPC in Spalte F
Allerdings bekomme ich da leider einen Fehler beim Kompilieren wegen eines unzulässigen oder nicht ausreichend definierten Verweises - (.Cells) markiert er mir hierbei.
Hat jemand eine Idee wie ich es umschreiben müsste?
Danke und Gruß
Rahel
Anzeige
Der Punkt .
11.01.2018 03:36:06
Matthias
Hallo Rahel
Der . (Punkt) vor Cells erwartet eine vorgeschaltete With-Anweisung.
Lass mal den Punkt weg, wenn es keine With-Anweisung gibt.
Gruß Matthias
AW: Der Punkt .
11.01.2018 10:33:46
Rahel
Hallo Matthias,
danke dir für den Hinweis. Ich habe den Punkt rausgenommen, allerdings bekomme ich nun an folgender Stelle einen Syntaxfehler:
.Rows(lngIndex).Copy Destination:=.Range(.Rows(lngIndex + 1), .Rows(
lngIndex + AnzIPC - 1))
Ich habe auch da versucht, ob es klappt, wenn ich die Punkte rausnehme, aber dann wird die Zeile rot markiert und es scheint gar nichts mehr zu stimmen :/
Hoffe, du kannst mir da nochmal weiterhelfen!
Besten Dank
Rahel
Anzeige
AW: Kopieren von Zeilen abhängig von Anzahl Zeilen
11.01.2018 11:50:15
Zeilen
Hallo,
teste mal:
Sub Main()
Dim arrIn, arrTmp, Tx, arrOut()
Dim i As Long, lCount As Long
arrIn = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, 5)
'Anzahl Datensätze (IPC) ermitteln
For i = 1 To UBound(arrIn)
arrTmp = Split(arrIn(i, 2), Chr(10))
For Each Tx In arrTmp
If Len(Tx) Then lCount = lCount + 1
Next Tx
Next i
ReDim arrOut(1 To lCount + 1, 1 To 5) 'AusgabeArray dimensionieren
lCount = 1
'Überschriften
arrOut(lCount, 1) = arrIn(1, 1)
arrOut(lCount, 2) = arrIn(1, 2)
arrOut(lCount, 3) = arrIn(1, 3)
arrOut(lCount, 4) = arrIn(1, 4)
arrOut(lCount, 5) = arrIn(1, 5)
'Daten auslesen
For i = 2 To UBound(arrIn)
arrTmp = Split(arrIn(i, 2), Chr(10))
For Each Tx In arrTmp
If Len(Tx) Then
lCount = lCount + 1
arrOut(lCount, 1) = arrIn(i, 1)
arrOut(lCount, 2) = Tx
arrOut(lCount, 3) = arrIn(i, 3)
arrOut(lCount, 4) = arrIn(i, 4)
arrOut(lCount, 5) = arrIn(i, 5)
End If
Next Tx
Next i
'Ausgabe in neues Blatt
Worksheets.Add.Cells(1, 1).Resize(UBound(arrOut), UBound(arrOut, 2)) = arrOut
End Sub

Gruß
Rudi
Anzeige
AW: Kopieren von Zeilen abhängig von Anzahl Zeilen
11.01.2018 17:08:08
Zeilen
Hallo Rudi,
wow !!! Ja, das funktioniert. Einzig er kopiert mir lediglich die ersten 5 Spalten, ich hätte aber gerne die komplette Zeile (mit insgesamt 21 Spalten) - habe es mal selbst versucht händisch anzupassen, aber leider ohne Erfolg (mir werden weiterhin nur die ersten 5 Spalten kopiert):
Sub Main()
Dim arrIn, arrTmp, Tx, arrOut()
Dim i As Long, lCount As Long
arrIn = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, 21)
'Anzahl Datensätze (IPC) ermitteln
For i = 1 To UBound(arrIn)
arrTmp = Split(arrIn(i, 2), Chr(10))
For Each Tx In arrTmp
If Len(Tx) Then lCount = lCount + 1
Next Tx
Next i
ReDim arrOut(1 To lCount + 1, 1 To 21) 'AusgabeArray dimensionieren
lCount = 1
'Überschriften
arrOut(lCount, 1) = arrIn(1, 1)
arrOut(lCount, 2) = arrIn(1, 2)
arrOut(lCount, 3) = arrIn(1, 3)
arrOut(lCount, 4) = arrIn(1, 4)
arrOut(lCount, 5) = arrIn(1, 5)
'Daten auslesen
For i = 2 To UBound(arrIn)
arrTmp = Split(arrIn(i, 2), Chr(10))
For Each Tx In arrTmp
If Len(Tx) Then
lCount = lCount + 1
arrOut(lCount, 1) = arrIn(i, 1)
arrOut(lCount, 2) = Tx
arrOut(lCount, 3) = arrIn(i, 3)
arrOut(lCount, 4) = arrIn(i, 4)
arrOut(lCount, 5) = arrIn(i, 5)
End If
Next Tx
Next i
'Ausgabe in neues Blatt
Worksheets.Add.Cells(1, 1).Resize(UBound(arrOut), UBound(arrOut, 2)) = arrOut
End Sub

Wenn Du da noch einen Tip für mich hättest wie ich das anpassen kann, wäre ich dir sehr dankbar!
Schönen Abend!
Rahel
Anzeige
AW: Kopieren von Zeilen abhängig von Anzahl Zeilen
11.01.2018 19:52:03
Zeilen
Hallo,
so:
Sub Main()
Dim arrIn, arrTmp, Tx, arrOut()
Dim i As Long, lCount As Long, j As Integer
Const AnzSpalten As Long = 21
arrIn = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, AnzSpalten)
'Anzahl Datensätze (IPC) ermitteln
For i = 1 To UBound(arrIn)
arrTmp = Split(arrIn(i, 2), Chr(10))
For Each Tx In arrTmp
If Len(Tx) Then lCount = lCount + 1
Next Tx
Next i
ReDim arrOut(1 To lCount + 1, 1 To AnzSpalten) 'AusgabeArray dimensionieren
lCount = 1
'Überschriften
For j = 1 To AnzSpalten
arrOut(lCount, j) = arrIn(1, j)
Next j
'Daten auslesen
For i = 2 To UBound(arrIn)
arrTmp = Split(arrIn(i, 2), Chr(10))
For Each Tx In arrTmp
If Len(Tx) Then
lCount = lCount + 1
For j = 1 To AnzSpalten
If j = 2 Then
arrOut(lCount, j) = Tx
Else
arrOut(lCount, j) = arrIn(i, j)
End If
Next j
End If
Next Tx
Next i
'Ausgabe in neues Blatt
Worksheets.Add.Cells(1, 1).Resize(lCount, AnzSpalten) = arrOut
End Sub
Geht ab wie Schmitz' Katze, ne?
Gruß
Rudi
Anzeige
AW: Kopieren von Zeilen abhängig von Anzahl Zeilen
11.01.2018 20:28:25
Zeilen
Oh man, soo gut!!! Funktioniert einfach perfekt.
Tausend Dank und einen schönen Abend!
Rahel

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige