Problem mit eindeutiger Zuordnung

Hallo liebes Forum,
ich möchte mit VBA in verschiedenen Sheets (IPC0 bis IPC10) abhängig von der Anzahl an eingetragenen IPC Klassen in den Spalten F bis O jede Zeile bspw. in IPC3:
1. 3 mal kopieren
2. die Werte in den Spalten F bis H "spezifisch" verteilen.
Ziel ist es also, am Ende jede Zeile 3 mal, dafür aber mit einer einzigen IPC Klasse in der Tabelle zu haben. Aus der Ursprungszeile sollen demnach die IPC Klassen aus Spalte G und H (die auf die beiden kopierten Zeilen verteilt wurden) gelöscht werden.
(Für IPC 4 sollten die Zeilen 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.
Hier mein eher trauriger erster Versuch:
Option Explicit

Sub Unique()
Dim i As Long, lngLastRow As Long, lngNext As Long
Dim objSheet As Object
Dim IPC3 As Worksheet
Set IPC3 = ActiveWorkbook.ActiveSheet
With Sheets("IPC3")
IngLastRow = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
For i = 2 To IngLastRow
.EntireRow(lngIndex).Copy Destination:=.Offset(1, 0)
Next
End With
End Sub

Ich freue mich auf eure Ideen und bin schon jetzt ganz dankbar, wenn ihr mir weiterhelfen könnt!!!
Anbei noch die Datei:
https://www.herber.de/bbs/user/118420.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Test2() Dim lngIndex As Long, lngLastRow As Long, lngNext As Long Dim objSheet As Worksheet Dim J As Integer, AnzIPC As Integer, Spalte As Long, StatusCalc As Long With Application StatusCalc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With For Each objSheet In ActiveWorkbook.Worksheets With objSheet If Left(.Name, 3) = "IPC" Then lngLastRow = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row) For lngIndex = lngLastRow To 2 Step -1 AnzIPC = .Cells(lngIndex, 16).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

Beliebteste Forumthreads (12 Monate)

Problem mit eindeutiger Zuordnung

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread