Sarakkeittainen tietojen poiminta

Ruokahalu kasvaa syödessä näköjään...
nyt ei väliä montako samaa aluetta löytyy...

Function Etsi(Hakuehto As Variant) As Range
'etsii Sheet1 sarakkeesta A ja siirtää Sheet2 sarakkeeseen O
'oletuksena, että haettavat tiedot vain sarakkeessa A
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Taul1").Activate
With Range("A:A")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set Etsi = solu
EkaOsoite = solu.Address
Do
Set Etsi = Union(Etsi, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address EkaOsoite
End If
End With
End Function

Sub HakuEhdoilla()
On Error Resume Next
Dim Löydetty As Range
Dim Löydetty2 As Range
Dim solu As Range
Dim vika As Long
Set Löydetty = Etsi(Chr(126) & Range("E1"))
Set Löydetty2 = Etsi(Chr(126) & Range("E2"))
If Löydetty.Areas.Count = Löydetty2.Areas.Count Then
For i = 1 To Löydetty.Areas.Count
Range(Löydetty.Areas(i).Cells(1, 1).Offset(1, 0).Address & ":" & Löydetty2.Areas(i).Cells(1, 1).Address).Copy Worksheets("Taul2").Range("A65536").End(xlUp).Offset(1, 0)
vika = Worksheets("Taul2").Range("A65536").End(xlUp).Row
Worksheets("Taul2").Range("A" & vika) = Left(Worksheets("Taul2").Range("A" & vika), InStr(1, Worksheets("Taul2").Range("A" & vika), "~", 1) - 1)
Next
Else
MsgBox "Ristiriita alueiden kanssa"
End If
End Sub

Keep EXCELing
@Kunde