How to search on two or more sheets?

[AlexAlexon]

This macro search on sheet1 and range ("A10:A250"). I need to change macro in the way so macro can search on sheet 2 and range ("B5:b25") and Sheet3 and range ("a1:a32").


Private Sub CommandButton1_Click()
Dim rFound As Range
Dim sFirstAdd As String
Dim rLook As Range
Dim rValue As Range
Dim k As Range
Set rValue = Sheet1.Range("A5")
Set rLook = Sheet1.Range("A10:A250")
Set rFound = rLook.Find(rValue.Value, , , xlWhole)
If rFound > 0 Then
rFound.EntireRow.Copy


With Worksheets("Sheet2").Range("1:2")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteComments
'.Cells(RW - 1, 1) = rFound.Value
'.Cells(RW, 2) = rFound.Offset(0, 2).Value
'.Cells(RW, 3) = rFound.Offset(0, 5).Value
'.Cells(RW + 1, 1) = rFound.Offset(1, 0).Value
End With
End If
If rFound > 0 Then
rFound.Offset(1, 0).EntireRow.Copy


With Worksheets("Sheet2").Range("2:2")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteComments

End With
End If

End Sub

[XLGibbs]

Not 100% sure I follow your issue or what the desired result is, but maybe this will give you some ideas.


Private Sub foo()
Dim rFound As Range
Dim rLook As Range
rValue As String
Dim rDest As Range
rValue = Sheet1.Range("A5")
Set rLook = Sheet1.Range("A10:A250")
Set rDest = Worksheets("Sheet2").Range("A1")


Set rFound = rLook.Find(rValue, , , xlWhole)
If Not rFound Is Nothing Then
rFound.EntireRow.Copy
rDest.PasteSpecial xlValues
rDest.PasteSpecial xlPasteComments
Set rDest = rDest.Offset(1, 0) 'reset the dest range to 1 row below
End If
'reset the range and do again
Set rLook = Worksheets("Sheet2").Range("B5:b25")
Set rFound = rLook.Find(rValue, , , xlWhole)
If Not rFound Is Nothing Then
rFound.EntireRow.Copy
rDest.PasteSpecial xlValues
rDest.PasteSpecial xlPasteComments
Set rDest = rDest.Offset(1, 0)
End If

Set rLook = Worksheets("Sheet3").Range("a1:a32")
Set rFound = rLook.Find(rValue, , , xlWhole)
If Not rFound Is Nothing Then
rFound.EntireRow.Copy
rDest.PasteSpecial xlValues
rDest.PasteSpecial xlPasteComments
Set rDest = rDest.Offset(1, 0)
End If


End Sub

[Bob Phillips]

Private Sub CommandButton1_Click()
Call UpdateData(rLook:=Sheet1.Range("A10:A250"), rValue:=Sheet1.Range("A5").Value)
Call UpdateData(rLook:=Sheet2.Range("B2:B25"), rValue:=Sheet1.Range("A5").Value)
Call UpdateData(rLook:=Sheet3.Range("A1:A32"), rValue:=Sheet1.Range("A5").Value)
End Sub

Private Sub UpdateData(rLook As Range, rValue As Range)
Dim rFound As Range
Dim sFirstAdd As String
Dim rLook As Range
Dim k As Range

Set rFound = rLook.Find(rValue.Value, , , xlWhole)
If rFound > 0 Then
rFound.EntireRow.Copy

With Worksheets("Sheet2").Range("1:2")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteComments

End With
End If
If rFound > 0 Then
rFound.Offset(1, 0).EntireRow.Copy

With Worksheets("Sheet2").Range("2:2")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteComments

End With
End If

End Sub

[AlexAlexon]

It works!Thanks very much!
But I need one more thing. This makro copy entire row but I don't need to copy value from column A.

[XLGibbs]

Specify the range to copy... rFound.Offset(,1).Resize(1,20).Copy

Would , for example, move one column to the right of the rFound cell, then resize to 1 row and 20 columns from there to copy that data to the location.

[AlexAlexon]

It works!!!!
XL gibbs and xld thanks very much!