'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@gmx.de
'Benutzung frei - ohne Gewähr

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+  finde den Suchwert als TEIL eines Zellinhalts in einer Selection des Quellarbeitsblattes
'+  und füge den Zellinhalt ab startzelle ins Zielarbeitsblatt ein
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Function suchen_und_einfuegen(suchwert As Variant, _
                              Optional quelle As Worksheet, _
                              Optional ziel As Worksheet, _
                              Optional startzelle As Range) As Long
Dim c As New Collection
Dim r As Range
Dim r1 As Range
Dim a As Range

suchen_und_einfuegen = -1
If quelle Is Nothing Or IsMissing(quelle) Then
    Set quelle = ActiveSheet
    Else
    quelle.Select
    End If
For Each a In Selection.Areas
    Set r = a.Find(suchwert, lookat:=xlPart, MatchCase:=False)
    Set r1 = r
    Do While Not r Is Nothing
        c.Add r
        Set r = a.FindNext(r)
        If r.Address = r1.Address Then Set r = Nothing
        Loop
    Next

If ziel Is Nothing Or IsMissing(ziel) Then
    Set ziel = ActiveSheet
    Else
    ziel.Select
    End If
Application.ScreenUpdating = False
If startzelle Is Nothing Then
     Set startzelle = ziel.Cells(1)
     Else
     Set startzelle = ziel.Range(startzelle.Address)
     End If
If IsError(c.Count) Then Exit Function
suchen_und_einfuegen = c.Count
For i = 1 To c.Count
   startzelle.Offset(i - 1, 0) = c.Item(i)
   Next i
Application.ScreenUpdating = True
quelle.Select
End Function

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+ Anwendungsbeispiel:
'+
'+  suche nach "k" in Zellen des aktiven Arbeitsblattes und füge die gefundenen
'+  Zellinhalte ab Zelle A1 in Blatt 2 ein
'+  dann suche nach "g" im aktiven Blatt und hänge die Treffer hinter die Liste
'+  aus Blatt 2
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Sub testKuG()
  anzahlk = suchen_und_einfuegen("K", , Sheets(2))
  anzahlg = suchen_und_einfuegen("G", , Sheets(2), Cells(anzahlk + 1, 1))
End Sub