Option
Explicit
Sub
TestIt()
Dim
c
As
Range, firstAddress
As
String
, z
As
Range
Sheets(
"Tabelle1"
).Activate
With
Sheets(
"Tabelle2"
).Range(
"J9:J30"
)
Set
c = .Find(What:=
Date
, LookIn:=xlValues)
If
Not
c
Is
Nothing
Then
firstAddress = c.Address
Do
Set
z = ZielZelle(c.Row,
"C10-H10"
)
If
Not
z
Is
Nothing
Then
_
Range(c.Offset(, -7), c.Offset(, -2)).Copy Destination:=z
Set
z = ZielZelle(c.Row,
"I10-K10"
)
If
Not
z
Is
Nothing
Then
_
Range(c.Offset(, -1), c.Offset(, 1)).Copy Destination:=z
Set
c = .FindNext(c)
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
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