[VBA] Iteration über Vlookup + Zeilen unterhalb einfügen

[xlsxvba]

Moin zusammen,

erstmal sorry für so einen langen Post!! Versuche mich kurz zu halten!
Ich wollte mich nochmal mit einem Problem hierher trauen. Mir fehlt nur ein letzter Schritt.
Unten füge ich meinen bisherigen (DAU-) Code ein aber zuerst einmal zum eigentlichen Problem:

Ich habe eine Excel Datei mit 2 Tabellenblättern: "Quelle" und "Ziel"


"Quelle" ist in etwa so aufgebaut:

A1=MainKey
B1=Werte 
C1= SubKey

Mein bisheriges Makro für "Ziel" ist so aufgebaut, dass ich einen MainKey in eine Zelle schreibe, und dann alle Zeilen mit diesem MainKey aus "Quelle" kopiere und in "Ziel" einfüge.

Beispiel in "Ziel" für MainKey = 1

MainKey | Werte ... | SubKey
1              | text123    | 0
1              | text123    | 5
1              | text123    | 10
1              | text123    | 0

Was ich suche:

In Zeile n: Ist SubKey = 0 --> tue nichts, prüfe nächste Zeile
In Zeile n: Ist SubKey > 0 --> nimm diesen Wert (hier 5) und füge hierunter alle Zeilen aus "Quelle" mit dem MainKey 5 ein. Der SubKey wird also zum MainKey.

MainKey | Werte ... | SubKey
1              | text123    | 0
1              | text123    | 5
5              | text123    | 0
1              | text123    | 10
1              | text123    | 0

In neuer eingefügter Zeile (MainKey=5): Ist SubKey = 0 --> tue nichts da Null, prüfe nächste Zeile!

MainKey | Werte ... | SubKey
1              | text123    | 0
1              | text123    | 5
5              | text123    | 0
1              | text123    | 10
1              | text123    | 0


In Zeile: Ist SubKey = 0 --> tue nichts, prüfe nächste Zeile
In Zeile: Ist SubKey > 0 --> nimm diesen Wert (hier 10) und füge hierunter alle Zeilen aus "Quelle" mit dem MainKey 10 ein.

MainKey | Werte ... | SubKey
1              | text123    | 0
1              | text123    | 5
5              | text123    | 0
1              | text123    | 10
10            | text123    | 15
10            | text123    | 20
1              | text123    | 0
.....           | text123    | 0
n              | text123    | 0


Usw. ... Ich hoffe ich konnte es einigermaßen erklären :)

Also sobald ein SubKey ungleich Null ist, sollen alle Zeilen mit diesem Wert als MainKey in "Quelle" gesucht darunter kopiert werden.
Nach dem Kopieren soll dann Stück für Stück nach diesem Muster weitergesucht werden, bis ein SubKey Null ist.

Ich würde mich über jeden Tipp freuen!! Danke vorab!

Code:

Option Explicit

Sub Test()

' Clear Contents & Formats
ActiveSheet.Range("A2:BB9999").ClearContents
ActiveSheet.Range("A2:BB9999").ClearFormats

    Sheets("Quelle").Select
    Rows("3:4").Select
    Selection.Copy
    Sheets("Ziel").Select
    Rows("3:3").Select
    Selection.Insert shift:=xlDown
    Columns("A:AE").Select
    Columns("A:AE").EntireColumn.AutoFit
    ActiveWindow.ScrollColumn = 1
    'Range("A4:AE4").AutoFilter
    'Range("A3").Select



' Variablen definieren
Dim Cell As Range
Dim InputCell As Variant ' Input Zelle deklarieren
InputCell = Worksheets("Ziel").Range("G1").Value 'Wert aus Zelle G1 in Variable einlesen

' Kopiere alle Zeilen mit dem Wert aus InputCell und fügt sie im anderen Blatt ein
With Sheets("Quelle")
    ' loop column H untill last cell with value (not entire column)
    For Each Cell In .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        If Cell.Value = InputCell Then
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=Sheets("Ziel").Rows(Cell.Row)
        End If
    Next Cell
End With



' Leere Zeilen löschen
Dim Zeile As Long
Dim ZeileMax As Long

With Sheets("Ziel")
ZeileMax = .UsedRange.Rows.Count
For Zeile = ZeileMax To 3 Step -1
If .Cells(Zeile, 1).Value = "" Then
.Rows(Zeile).Delete
End If
Next Zeile
End With

Range("A3").Select


' hier fehlender Teil  for i prüfe SubKey, wenn 0 gehe zur nächsten Zeile, wenn > 0 dann suche in Quelle usw.



End Sub

[snb]

Bitt, lade mal eine Musterdatei hoch.

Verzichte auf 'Select' und 'activate' in VBA.

[xlsxvba]

Moin,
anbei ohne Makro zum Veranschaulichen:


Viele Grüße und Danke vorab! :)

[xlsxvba]

Moin,

ich habe es zumindest schon soweit, dass Werte größer Null im Ziel gefunden und in die Anzahl in der Quelle gesucht werden.
Was noch fehlt ist, dass die gefundene Anzahl gleich der einzufügenden Zeilen entsprechen soll und in die Werte aus der Quelle eingefügt werden sollen ...

Mein Code bisher funktioniert nur bei einem gefundenen Wert:

Code:

Dim ValueCountTarget As Variant
Dim FindValueCountSrc As Integer
Dim SrcRange As Range

Set SrcRange = Worksheets("Quelle").Range("A5:A20000")

With Sheets("Ziel")
    ' loop column V untill last cell with value (not entire column)
    For Each Cell In .Range("V5:V" & .Cells(.Rows.Count, "V").End(xlUp).Row)
        If Cell.Value > 0 Then
        ValueCountTarget = Cell.Value
       
        'Finde Anzahl der Werte in Quelle
        FindValueCountSrc = Application.WorksheetFunction.CountIf(SrcRange, ValueCountTarget)
       
        'füge neue Zeilen Anzahl von FindValueCountSrc unterhalb ein
        'hier Code
       
    Dim Col As Variant
    Dim BlankRows As Long
    Dim LastRow As Long
    Dim R As Long
    Dim StartRow As Long

        Col = "V"
        StartRow = 5
        BlankRows = 1

            LastRow = Cells(Rows.Count, Col).End(xlUp).Row

            Application.ScreenUpdating = False

            With ActiveSheet
For R = StartRow To LastRow + 1 Step 1
If .Cells(R, Col) > 0 Then
.Cells(R + FindValueCountSrc, Col).EntireRow.Insert Shift:=xlDown
End If
StartRow = StartRow + FindValueCountSrc
Next R
End With
Application.ScreenUpdating = True
       
       
        MsgBox (FindValueCountSrc)
        End If
    Next Cell
End With




End Sub

[schauan]

Hallöchen,

oder so. Hab hier die Bereichsgröße der Quelle fest programmiert, wie man die letzte Zelle bekommt hat Du ja im anderen Code. Im Ziel ergibt sich das Ende aus der ersten Zelle in SPalte K, wo nix steht.

Code:

Sub Makro1()
'Variablendeklarationen, Integer
Dim iCnt%
'Startzeile setzen
iCnt = 20
'Schleife solange was in Spalte K steht
Do While Cells(iCnt, 11).Value <> ""
    'Wenn in K mahr als 0 steht, dann
    If Cells(iCnt, 11).Value > 0 Then
      'Mit dem Quellblatt
      With Sheets("Quelle")
        'Filter im Bereich A3:M99, Spalte 1 (A),  mit dem Wert aus Spalte K setzensetzen
        .Range("$A$3:$M$99").AutoFilter Field:=1, Criteria1:=Cells(iCnt, 11).Value
        'Bereich kopieren - es werden nur sichtbare Zellen genommen
        .Range("A5:M99").Copy
        'Unter die Zeile vom Ziielblatt einfuegen
        Sheets("Ziel").Cells(iCnt + 1, 1).Insert Shift:=xlDown
        'Filter aufklappen
        .Range("$A$3:$M$99").AutoFilter Field:=1
      'Ende Mit dem Quellblatt
      End With
    'Ende Wenn in K mahr als 0 steht, dann
    End If
    'Schleifenzaehler hochsetzen
    iCnt = iCnt + 1
'Ende Schleife solange was in Spalte K steht
Loop
End Sub