Poimiva hakumakro

tee lomake ja lisaa siihen tekstiruutu, luetteloruutu ja komentopainike. Oletusnimilla nyt...

lomakkeeseen seuraavat koodit

jos haluat , etta tiedot tulevat allekkain niin hipsaa rivi
Siirto.Copy Range("Sheet2!A65536").End(xlUp).EntireRow

ja poista hipsu rivilta
' Siirto.Copy Range("Sheet2!A65536").End(xlUp).Offset(1, 0).EntireRow

jos et halua etsia koko taulukosta niin muuta EtsiJaSiirrไ proseduurissa With Cells
esim A sarake With Range("A:A")
Private Sub CommandButton1_Click()
Dim Siirto As Range
For i = 0 To ListBox1.ListCount
If ListBox1.Selected(i) = True Then
' MsgBox "Valitsit: " & ListBox1.List(i)
Set Siirto = EtsiJaSiirrไ(ListBox1.List(i)).EntireRow
Siirto.Copy Range("Sheet2!A65536").End(xlUp).EntireRow
' Siirto.Copy Range("Sheet2!A65536").End(xlUp).Offset(1, 0).EntireRow
Exit Sub
End If
Next
End Sub

Private Sub TextBox1_Change()
Dim Haku As Range
Dim solu As Range
Set Haku = EtsiJaSiirrไ(TextBox1.Text & "*")
ListBox1.Clear
If Not Haku Is Nothing Then
For Each solu In Haku
ListBox1.AddItem solu
Next

End If
End Sub

Function EtsiJaSiirrไ(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
With Cells
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set EtsiJaSiirrไ = solu
EkaOsoite = solu.Address
Do
Set EtsiJaSiirrไ = Union(EtsiJaSiirrไ, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address EkaOsoite
End If
End With
End Function