Cut & paste the data to new sheet if condition matches

[hdgfss]

Hi Experts,

I am looking for a macro that will do the things mentioned below
macro will be placed in macro.xlsm,both files are located in different places so the path will be hardcoded in the macro so that i can change it as per my needs
sheet name can be anything
Plz see the sample file & the output file


If column B of sheet2 of book2.xlsx matches with column I of 1.xls then cut that entire row & paste it to new sheet in 1.xls(Plz name the new sheet as output1)
(header will be same in new sheet also)

& If Book2.xlsx has a blank sheet2 then dont do anything


Thnx For the Help

1.xls

drive.google.com

Book2.xlsx

drive.google.com

OutPut.xls

drive.google.com

 

[DanteAmor]

Try this. You must fit the folder names, file names, and sheet names.

Sub cut_paste()
  Dim wb1 As Workbook, wb2 As Workbook
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim lr1 As Long
  Dim rng As Range, c As Range, f As Range
  
  Application.ScreenUpdating = False
  Set wb1 = Workbooks.Open("C:\books\1.xls")
  Set wb2 = Workbooks.Open("C:\books\Book2.xlsx")
  
  Set sh1 = wb1.Sheets(1)
  Set sh2 = wb2.Sheets("Sheet2")
  
  lr1 = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
  Set rng = sh1.Range("A" & lr1)
  
  For Each c In sh2.Range("B2", sh2.Range("B" & Rows.Count).End(3))
    Set f = sh1.Range("I:I").Find(c, , xlValues, xlWhole)
    If Not f Is Nothing Then
      Set rng = Union(rng, sh1.Range("A" & f.Row))
    End If
  Next
  
  If rng.Count > 1 Then
    wb1.Sheets.Add(After:=wb1.Sheets(wb1.Sheets.Count)).Name = "Output1"
    sh1.Rows(1).Copy wb1.Sheets("Output1").Range("A1")
    rng.EntireRow.Copy wb1.Sheets("Output1").Range("A2")
    rng.EntireRow.Delete
  End If
  
  wb1.Close True
  wb2.Close False
End Sub

 

[hdgfss]

Awesome DanteAmor Sir
Thnx Alot For helping me in solving this Problem Sir
Have a Awesome Day

 

[DanteAmor]

Im glad to help you, thanks for the feedback.