Macro that searches with the name a cell from a selection of items from a list and finds it in another sheet - excel

Question

I am new in VBA and I want to write a program that when I manually select 1 or more items from a list the code searches with the name of the item and picks it from another sheet, copies the whole row and pastes it in a 3rd sheet. Is that possible? Preferably with a click of a button the selection is made. Thanks a lot!

Answer 1

Here is an example.
Sub FindAndMove()
Dim Finder As Range
Dim TheItem As Variant
With Sheets("Sheet1")
If Selection.CountLarge = 1 And Not Intersect(Selection, .Range("A2:A11")) Is Nothing Then
TheItem = Selection.Value
Else
MsgBox ("Please select an item from the list")
Exit Sub
End If
End With
With Sheets("Sheet2")
Set Finder = .Range("A:A").Find(TheItem, LookAt:=xlWhole)
If Finder Is Nothing Then
MsgBox ("Item not found!")
Exit Sub
End If
With Sheets("Sheet3")
Finder.EntireRow.Copy .Range("A" & .UsedRange.Rows.CountLarge + 1)
.Select 'Optional - show sheet 3
End With
End With
End Sub
Walking through the code:
When they click the button, if they only select 1 cell that's in our list.
Get the value of the item they selected
On Sheet2 - go find that value in column A
If you find it, copy the entire row to the end of Sheet3
You can modify the code by changing the sheet names in Sheet("Sheet1") to whatever you want.
You can also change the list range by changing .Range("A2:A11")
You can change the range to search by changing .Range("A:A")
Sheet 1:
Sheet 2:
Sheet 3: (after we select item 3 and click Find and Move)
Error Handling:
Edit:
Code to find multiple occurrences using FindNext
Sub FindAndMove()
Dim Finder As Range
Dim FirstAddress As Variant
Dim TheItem As Variant
With Sheets("Sheet1")
If Selection.CountLarge = 1 And Not Intersect(Selection, .Range("A2:A11")) Is Nothing Then
TheItem = Selection.Value
Else
MsgBox ("Please select an item from the list")
Exit Sub
End If
End With
With Sheets("Sheet2")
Set Finder = .Range("A:A").Find(TheItem, LookAt:=xlWhole)
If Finder Is Nothing Then
MsgBox ("Item not found!")
Exit Sub
End If
FirstAddress = Finder.Address
Do
With Sheets("Sheet3")
Finder.EntireRow.Copy .Range("A" & .UsedRange.Rows.CountLarge + 1)
End With
Set Finder = .Range("A:A").FindNext(Finder)
Loop While Not Finder Is Nothing And Finder.Address <> FirstAddress
End With
Sheets("Sheet3").Select 'Optional - Select Sheet3 After.
End Sub