|
bin gespannt ob du ...............?
Option Explicit
Sub TestIt()
Dim c As Range, firstAddress As String, z As Range
'Zieltabelle
Sheets("Tabelle1").Activate
'Beginne 1 über dem Bereich, wegen .Find - Methode
With Sheets("Tabelle2").Range("J9:J30")
'aus dem Handbuch für ...
Set c = .Find(What:=Date, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
'für Bereich1
Set z = ZielZelle(c.Row, "C10-H10")
If Not z Is Nothing Then _
Range(c.Offset(, -7), c.Offset(, -2)).Copy Destination:=z
'für Bereich2
Set z = ZielZelle(c.Row, "I10-K10")
If Not z Is Nothing Then _
Range(c.Offset(, -1), c.Offset(, 1)).Copy Destination:=z
'weitersuchen
Set c = .FindNext(c)
'Ausschluss
If c.Row = 9 Then Exit Do
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
Private Function ZielZelle(Zeile As Long, Bereich As String) As Range
On Error Resume Next
'Zielzelle abfragen
Set ZielZelle = Application.InputBox( _
prompt:="Klicke in die Zielzelle für " & Bereich, _
Title:="Treffer in Zeile " & Format(Zeile, "#0"), _
Type:=8)
On Error GoTo 0
End Function
|