Dringend: Anpassung/Änderung eines VBA codes

Hallo liebe Excel Freunde,
dringend Hilfe gesucht!!!
Nachdem mir bereits durch eure Hilfe ein VBA Code für mein Problem erstellt wurde, suche ich nun Hilfe um den Code noch ein Stück weit anzupassen.
https://www.herber.de/bbs/user/75729.zip
Und zwar besteht die angefügte Datei aus drei Tabellenblättern. Die Tabelle R holt sich die Daten aus Tabelle P und M. Da die Zeile test1 und test2 in Tabelle P nur einmal vorkommt werden diese daten auch nur einmal in Tabelle R übertragen. In Tabelle M sind unter test1 und test2 aber jeweils 2 Zeilen eingetragen. Demzufolge werden diese Zeilen auch in der Anzahl in Tabelle R wiedergegeben. Es wird immer der Fall sein, dass die unter Spalte A aus Tabelle P eingetragenen Nr. immer nur einmal vorkommt.
Was ich gern möchte ist folgendes:
Jedesmal wenn in Tablle M eine nr. in Spalte A mehrmals vorkommt und nach Tabelle R übertragen wird, soll in Tabelle R die gleiche Anzahl an Zeilen generiert werden um die Daten, welche unter dieser nr. in Tabelle P eingetragen sind zu übertragen. Dies bedeutet, dass der unter dieser No. stehenden Eintrag aus Tabelle P zwar derselbe ist, aber genau so häufig angezeigt werden soll, wie es Daten mit dieser no. aus Tabelle M gibt.
In der Anlage in Tabelle R sind die Zeilen gelb markiert in welche die Daten aus tabelle P mit der gleichen nr. nochmals generiert werden sollen.
Ich bitte um eure Hilfe, da ich keine Anpassungsmöglichkeit des vorhandenen Codes für dieses Problem weiß.
Gruß und vielen Dank im Voraus
Manu

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Manu,
wenn es mehr Zeilen werden können entweder weiter anpassen oder mich noch mal anschreiben.
Anbei ein Ansatz

Sub tabellen_zusammenfassen()
Dim refNr As Range, sNr As Range
Dim lZeile1 As Long, lZeile2 As Long, lZeile3 As Long
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
Set wks1 = Worksheets("Tabelle R")
Set wks2 = Worksheets("Tabelle P")
Set wks3 = Worksheets("Tabelle M")
lZeile1 = wks1.Cells(Rows.Count, 1).End(xlUp).Row
lZeile2 = wks2.Cells(Rows.Count, 1).End(xlUp).Row
lZeile3 = wks3.Cells(Rows.Count, 1).End(xlUp).Row
If Not lZeile1 = 1 Then wks1.Range(wks1.Cells(2, 1), wks1.Cells(lZeile1, 18)).ClearContents
lZeile1 = 2
For Each refNr In wks2.Range(wks2.Cells(2, 1), wks2.Cells(lZeile2, 1))
If refNr  "" Then
wks1.Cells(lZeile1, 1) = refNr.Value
wks1.Cells(lZeile1, 2) = refNr.Offset(0, 1)
wks1.Cells(lZeile1, 3) = refNr.Offset(0, 2)
wks1.Cells(lZeile1, 4) = refNr.Offset(0, 3)
wks1.Cells(lZeile1, 5) = refNr.Offset(0, 4)
wks1.Cells(lZeile1, 6) = refNr.Offset(0, 5)
wks1.Cells(lZeile1, 7) = refNr.Offset(0, 6)
wks1.Cells(lZeile1, 8) = refNr.Offset(0, 7)
wks1.Cells(lZeile1, 9) = refNr.Offset(0, 8)
wks1.Cells(lZeile1, 10) = refNr.Offset(0, 9)
For Each sNr In wks3.Range(wks3.Cells(2, 1), wks3.Cells(lZeile3, 1))
If refNr = sNr Then
wks1.Cells(lZeile1, 1) = sNr.Value
wks1.Cells(lZeile1, 11) = sNr.Offset(0, 1)
wks1.Cells(lZeile1, 12) = sNr.Offset(0, 2)
wks1.Cells(lZeile1, 13) = sNr.Offset(0, 3)
wks1.Cells(lZeile1, 14) = sNr.Offset(0, 4)
wks1.Cells(lZeile1, 15) = sNr.Offset(0, 5)
wks1.Cells(lZeile1, 16) = sNr.Offset(0, 6)
wks1.Cells(lZeile1, 17) = sNr.Offset(0, 7)
wks1.Cells(lZeile1, 18) = sNr.Offset(0, 8)
lZeile1 = lZeile1 + 1
End If
Next
lZeile1 = lZeile1 + 1
End If
Next
If wks1.Cells(3, 1).Value = "test1" Then
Range("B2:I2").Select
Selection.Copy
Range("B3").Select
ActiveSheet.Paste
End If
If wks1.Cells(4, 1).Value = "test1" Then
Range("B3:I3").Select
Selection.Copy
Range("B4").Select
ActiveSheet.Paste
End If
If wks1.Cells(6, 1).Value = "test2" Then
Range("B5:I5").Select
Selection.Copy
Range("B6").Select
ActiveSheet.Paste
End If
If wks1.Cells(7, 1).Value = "test2" Then
Range("B6:I6").Select
Selection.Copy
Range("B7").Select
ActiveSheet.Paste
End If
Set wks1 = Nothing
Set wks2 = Nothing
Set wks3 = Nothing
End Sub

Gruß René

Option Explicit Sub tabellen_zusammenfassen() Dim refNr As Range, sNr As Range, i As Integer, j As Integer Dim lZeile1 As Long, lZeile2 As Long, lZeile3 As Long Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet Set wks1 = Worksheets("Tabelle R") Set wks2 = Worksheets("Tabelle P") Set wks3 = Worksheets("Tabelle M") lZeile1 = wks1.Cells(Rows.Count, 1).End(xlUp).Row lZeile2 = wks2.Cells(Rows.Count, 1).End(xlUp).Row lZeile3 = wks3.Cells(Rows.Count, 1).End(xlUp).Row If Not lZeile1 = 1 Then wks1.Range(wks1.Cells(2, 1), wks1.Cells(lZeile1, 18)).ClearContents lZeile1 = 2 For Each refNr In wks2.Range(wks2.Cells(2, 1), wks2.Cells(lZeile2, 1)) If refNr "" Then wks1.Cells(lZeile1, 1) = refNr.Value For i = 1 To 9 wks1.Cells(lZeile1, i + 1) = refNr.Offset(0, i) Next i j = 0 For Each sNr In wks3.Range(wks3.Cells(2, 1), wks3.Cells(lZeile3, 1)) If refNr = sNr Then j = j + 1 wks1.Cells(lZeile1, 1) = sNr.Value For i = 1 To 8 wks1.Cells(lZeile1, i + 10) = sNr.Offset(0, 1) Next i If j > 1 Then wks1.Cells(lZeile1, 1) = refNr.Value For i = 1 To 9 wks1.Cells(lZeile1, i + 1) = refNr.Offset(0, i) Next i End If lZeile1 = lZeile1 + 1 End If Next lZeile1 = lZeile1 + 1 End If Next Set wks1 = Nothing Set wks2 = Nothing Set wks3 = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Dringend: Anpassung/Änderung eines VBA codes

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dringend: Anpassung/Änderung eines VBA codes

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread