Office: (Office 2013) Bestimmte Namen in der Tabelle suchen kopieren und einfügen

Hallo zusammen,

ich habe eine Aufgabe in Excel, die ich mithilfe VBA lösen möchte(wenn es überhaupt geht;) Da ich noch sehrwenige Ahbung von Vba habe, komme ich nicht weiter und beschlossen Hilfe von profis zu holen.
ich habe von dem originalen Daten ein ähnliches Beispiel abgebildet, um das Problem einfacher darzustellen und dies wäre wie folgt:

Ich habe ein Mappe Namens BSP, mit drei Tabellen:
In der Tabelle1("Quelle"), ist der Datensatz, von dem ich nur die bestimmte Zeilen brauche, Z.B.: In Tabelle3 "Namen" sind nur bestimmte, für mich relevante namen eingetragen. Nun möchte ich durch Schleife jeden einzelnen namen in der Tabelle 3 in der Spalte B von Tabelle1 suchen, finden und mit entsprechenedem projekt und Stunden kopieren und in die Tabelle 2("Ziele) einfügen.

Durch Recherche im Internet, in Büchern habe ich ein Cod geschrieben, aber da tut fast gar nicht, er läuft zwar durch definierten Namen in der Tabelle1 und kopiert, aber fügt nicht in die Zieltabelle ein.

Geht es überhaupt sowas per Makro, oder muss ich mir was anders überlegen? Würde mich über jede Hinweise, Ansätze, Vorschläge freuen.

Excel Mappe habe ich im Anhang eingefügt,
Hier ist mein Cod:
Option Explicit

Sub ÜberNamernSucheUndKopieren()

'für Tab.1"Quelle"
Dim zeileQ As Long
Dim zeileMax As Long

'für Tab.3"Namen"
Dim zeileN As Long
Dim ma_name As Range
Dim ma_namenListe As Range

'für Tab.2"Ziel"
Dim zeileZ As Long
Dim spalteMax As Long

Application.ScreenUpdating = False
zeileN = 2
While Tabelle3.Cells(zeileN, 1) <> ""
'ma_name = Tabelle3.Cells(zeileN, 1)

Tabelle3.Activate
With Tabelle3

For Each ma_name In Range("NamenListe")

Tabelle1.Activate
zeileMax = Tabelle1.UsedRange.Rows.Count
spalteMax = Tabelle1.UsedRange.Columns.Count
zeileQ = 4

For zeileQ = 4 To zeileMax

If ma_name = Tabelle1.Cells(zeileQ, 2) Then
Tabelle1.Range(Cells(zeileQ, 2), Cells(zeileQ, spalteMax)).Copy

With Tabelle2
zeileZ = 2

If .Cells(zeileZ, 1).Value = "" Then

.Cells(zeileZ, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
zeileZ = zeileZ + 1

End If

End With

End If

Next zeileQ

Next ma_name

End With

Wend
zeileN = zeileN + 1

Application.ScreenUpdating = True

End Sub

Vielen Dank schonmal!

VG Fazi

 

Hi,

am rationellsten löste man das mit dem Autofilter:

Code:

Sub ÜberNamernSucheUndKopieren()
    Dim lngZiel As Long
    Dim lngZeile As Long
    Dim lngLetzte As Long
    lngZiel = 1
    With Worksheets("Quelle")
        lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
        For lngZeile = 1 To Worksheets("Namen").Range("NamenListe").Cells(Worksheets("Namen").Range("NamenListe").Cells.Count).Row
            If Not .AutoFilterMode Then .Range("B3").AutoFilter
            .Range("B3").AutoFilter field:=1, Criteria1:=Worksheets("Namen").Range("NamenListe").Cells(lngZeile)
            If .Range(.Cells(3, 2), .Cells(lngLetzte, 2)).SpecialCells(xlCellTypeVisible).Count > 1 Then
                .Range(.Cells(4, 2), .Cells(lngLetzte, 16)).SpecialCells(xlCellTypeVisible).Copy Worksheets("Ziel").Cells(lngZiel, 1)
                lngZiel = lngZiel + .Range(.Cells(3, 2), .Cells(lngLetzte, 2)).SpecialCells(xlCellTypeVisible).Count - 1
            End If
            .Range("B3").AutoFilter field:=1
        Next lngZeile
        .Range("B3").AutoFilter
    End With
End Sub

Bis später,
Karin