1 reply
rizvisa1
Feb 9, 2011 at 10:58 PM
- Posts
- 4479
- Registration date
- Thursday January 28, 2010
- Status
- Contributor
- Last seen
- May 5, 2022
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