match data form sheet1 and sheet2 and extract it out

[mathanraj76]

Hi..
I need help

I have a data in sheet1 in and sheet 2
where i need compare both and extract data from sheet 1 into output sheet
those data which not match will remain same in sheet1

I have attached sample data..


Thanks

[patel45]

Sub a()
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    Set sh3 = Sheets("Output")
    LR1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    LR2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row
    LR3 = sh3.Cells(Rows.Count, "A").End(xlUp).Row + 1
    For j = 2 To LR1
        Shname = sh1.Cells(j, 2).Value
        For i = 1 To LR2
          If sh2.Cells(i, 2).Value = Shname Then
            sh1.Rows(j).Cut sh3.Rows(LR3)
            LR3 = LR3 + 1
            Exit For
          End If
        Next
    Next
End Sub

[mathanraj76]

hi..thanks..

But when i run the code nothing is happen in sheet output..
No data which cut and paste into sheet output..
where it's match from sheet 2 in (column b) with sheet 1 in (column A)

Thanks

[patel45]

did you put the code in a module ? not in worksheet or workbook.
If problems attach again the new workbook with code

[HaHoBe]

Hi, mathanraj76,

if you run the code on your sample no action may be taken as there is nothing to be moved in Sheet1.

I guess it would be a lot easier to drop the blank rows in sheet1 prior to running the macro. If you donīt want that change the value for cblndDEL_BLANKS to False:

Sub EF977395()
Dim wsSh1 As Worksheet
Dim wsSh2 As Worksheet
Dim wsOut As Worksheet
Dim lngCounter As Long

Const cblndDEL_BLANKS As Boolean = True

Set wsSh1 = Sheets("Sheet1")
Set wsSh2 = Sheets("Sheet2")
Set wsOut = Sheets("Output")


On Error Resume Next
With wsSh1
  If cblndDEL_BLANKS Then .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
On Error GoTo 0

For lngCounter = 2 To wsSh1.Cells(Rows.Count, "A").End(xlUp).Row
    If wsSh1.Cells(lngCounter, 2).Value <> "" Then
        If WorksheetFunction.CountIf(wsSh2.Range("B:B"), wsSh1.Cells(lngCounter, 2).Value) > 0 Then
            wsSh1.Rows(lngCounter).Cut wsOut.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    End If
Next lngCounter

Set wsOut = Nothing
Set wsSh2 = Nothing
Set wsSh1 = Nothing
End Sub

Ciao,
Holger

[Winon]

@ HaHoBe,

I think your guess might be spot-on !!!

Kind regards.

[Winon]

@ HaHoBe,

Thank you for the Rep.

Ich danke Ihnen sehr.

Merry Christmas my friend !!!

Kind Regards.