1 response
rizvisa1
Posts
4478
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
766
Feb 9, 2011 at 10:58 PM
Feb 9, 2011 at 10:58 PM
Try this
Sub doMatchAndCopy() Dim sSrcSheet As String 'sheet where values to be searched are Dim sLookUpSheet As String 'sheet where matching rows are to be found Dim sFinalSheet As String 'sheet where the matched rows are to be pasted Dim sSrcValue As String Dim lSrcRow As Long Dim lLookUpRow As Long Dim lFinalRow As Long Dim rngFinalCell As Range 'three sheets sSrcSheet = "Sheet1" sLookUpSheet = "Sheet2" sFinalSheet = "Sheet3" 'find the last used cells on the final sheet where matched rows would be pasted Set rngFinalCell = Sheets(sFinalSheet).Cells.Find("*", Sheets(sFinalSheet).Cells(1, 1), , , xlByRows, xlPrevious) If (rngFinalCell Is Nothing) _ Then lFinalRow = 1 Else lFinalRow = rngFinalCell.Row End If Set rngFinalCell = Nothing 'going thru each row of source sheet till we encounter a blank cell lSrcRow = 2 Do While (Sheets(sSrcSheet).Cells(lSrcRow, "A") <> vbNullString) sSrcValue = Sheets(sSrcSheet).Cells(lSrcRow, "A") On Error Resume Next lLookUpRow = 0 lLookUpRow = Application.WorksheetFunction.Match(sSrcValue, Sheets(sLookUpSheet).Range("A:A"), 0) Err.Clear On Error GoTo 0 If (lLookUpRow > 0) _ Then Application.CutCopyMode = False lFinalRow = lFinalRow + 1 Sheets(sLookUpSheet).Rows(lLookUpRow).Copy Sheets(sFinalSheet).Cells(lFinalRow, "A").PasteSpecial Application.CutCopyMode = False End If lSrcRow = lSrcRow + 1 Loop End Sub
Feb 10, 2011 at 02:03 AM