Kopieren von Zeilen abhängig von Anzahl Zeilen
10.01.2018 19:32:30
Zeilen
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).
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