Office: (Office 2019) Zeilen nach XWert durchsuchen und nMal in Ziel kopieren

Hallo an die Spezialisten,

ich wollte mir Arbeit ersparen - jetzt bin ich seit Tagen damit beschäftigt eine Lösung zu finden (VBA-Neuling!)
Aufgabe :
3 Arbeitsblätter
Tab 1 Eingabe
Tab 2 Datenbank
Tab 3 Ziel

1. In Tab1 ist wird manuell eine Liste eingegeben (ab D6:E6 abwärts) - D sind MailAdressen : E enthält Anzahl. Die Länge und Inhalt dieser eingefügten Liste ist variabel (außer, dass es immer eine Mail und eine Zahl sind).
2. Die MailAdressen dienen der Zuordnung in der Datenbank Tab2. Ist die Mail in Tab1 vorhanden soll die entsprechende Zeile in Tab2 kopiert werden und in Tab3 (Ziel) eingefügt werden - undzwar so oft wie in Tab1 Spalte E (Anzahl) vorgegeben.
also Tab1
D (Mail) : E (Anzahl)
beispiel@mail : 4
suche in Tab2 in Spalte Y beispiel@mail und füge (wenn vorhanden) ganze Zeile in Tab3 ein (Tab2 enthält in Zeile 1 Spalten-Überschriften).
3. Wiederhole das ganze bis die Liste in Tab1 durch ist.
4. Als kleinen Zusatz: in Tab1 werden in Spalte B 1,3,6,7,8;9 fixe Werte eingetragen, die im Ziel (Tab3) in jeder Zeile gleich sind und dort eingefügt werden sollen. So weit, wie die Tabelle insgeamt am Ende wird.
Tab1 > Tab3 Spalte
B1 > A
B3 > B
B6 > AA
B7 > AB
B8 > AC
B9 > AD

Ich habe es teilweise schon mit Sverweis und Makro in Kombination versucht - aber vielleicht findet hier jemand eine elegantere Lösung ...
Würde mich freuen von euch zu lesen!

 

um Fehler zu vermeiden stellst du bitte ein Beispieldatei(Ohne echte Kontaktdaten) bereit.
In der Datei sind deine Bemühungen zu sehen und wie das Ergebnis aussehen soll.
VBA Neuling hin oder her. Von Nichts, kommt Nichts.

 

Wie Ihr wünscht ...

 

Sub kopieren()
Dim i As Long, loNeueZeile As Long, cnt As Long
Dim rngFund As Range
Dim inptanfang As Long

Application.ScreenUpdating = False

i = 6

With Worksheets("ZielTab")
'erste freie Zeile in Zieltab
If WorksheetFunction.CountA(.Range("A:A")) = 0 Then
loNeueZeile = 1
Else
loNeueZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End If
inptanfang = loNeueZeile
End With

'schleife über die Daten in tab1
Do While Worksheets(1).Cells(i, "D").Value <> ""

'Hier die Zeile Finden in tab 2
' Schleifenzähler i für Zellreferenz
'2) Überprüfe, ob in Spalte Y dieses Arbeitsblattes "mail" steht
With Tabelle2.Cells(1, "H").Resize(Tabelle2.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
Set rngFund = Tabelle2.Cells.Find(What:=Worksheets(1).Cells(i, "D").Value, LookIn:=xlValues, LookAt:=xlWhole)
End With
If Not rngFund Is Nothing Then

'2a) "rngfund" ist die Zelle aus Spalte H mit der mail
'3) Kopiere die Zeile mit mail und füge sie im zielTab unter die letzte Datenzeile ein.
With Tabelle2
.Range(.Range("C" & rngFund.Row), .Range("AZ" & rngFund.Row)).Copy
End With

With Worksheets("ZielTab")
'schleife für Einfügeanzahl
For cnt = 1 To Worksheets(1).Cells(i, "E").Value
'Zeile enfügen
.Range("A" & loNeueZeile).PasteSpecial (xlPasteValues)
loNeueZeile = loNeueZeile + 1
Next
End With

End If
i = i + 1
Loop

With Worksheets("ZielTab")
.Range(.Range("A" & inptanfang), .Range("A" & loNeueZeile - 1)).Value = Tabelle1.Range("B1").Value
.Range(.Range("B" & inptanfang), .Range("B" & loNeueZeile - 1)).Value = Tabelle1.Range("B3").Value
.Range(.Range("AA" & inptanfang), .Range("AA" & loNeueZeile - 1)).Value = Tabelle1.Range("B6").Value
.Range(.Range("AB" & inptanfang), .Range("AB" & loNeueZeile - 1)).Value = Tabelle1.Range("B7").Value
.Range(.Range("AC" & inptanfang), .Range("AC" & loNeueZeile - 1)).Value = Tabelle1.Range("B8").Value
.Range(.Range("AD" & inptanfang), .Range("AD" & loNeueZeile - 1)).Value = Tabelle1.Range("B9").Value
End With

Application.ScreenUpdating = True

End Sub

 

Ich neige voller Ehrfurcht mein Haupt ...
Vielen Dank lieber Ralf es funktioniert wie gewünscht
Ich werde bei dem Versuch zu verstehen, was da steht sicher etwas lernen.

 

Beim Verstehen hilft F1 und F8 und F9