Copy several cell values into another workbook based of the criteria

[loke2002249]

Hello, Everyone

Recently i want develop one code which it solve my problem for my excel book

this code is about copy several cell values on one workbook to another workbook base of the criteria of cell

there are two workbook here

1. source workbook name is Source and the worksheet name always different but this worksheet must be at sheets (6)
and i will develop a button in this worksheet to run the code and this worksheet always is starting point.00
2. destination workbook name is Destination and the worksheet name always is salesmanprofile

at the source workbook active sheet, it will find the any cell values = "yes" (i manually key in in the cell) at the column I then copy the same row but another cell in to destination workbook in different cell

example
at the cell i14 , it got "yes", then it will automatically copy cell B14, D14, E14 and H14 (4 cell)and paste into destination workbook salesmanprofile sheet

source workbook B14, D14, E14 and H14 = destination workbook B5, D5, E5 and H5

after that, it continue search next "yes" in the source workbook at column I, if find another yes at I20

then it will automatically copy cell B20, D20, E20 and H20 (4 cell)and paste into destination workbook salesmanprofile sheet

source workbook B20, D20, E20 and H20 = destination workbook B6, D6, E6 and H6....

Remarks : destination workbook got row 1 , 2 ,3 ,4 is empty... cannot paste anything on this 4 rows
It will continue do a same thing until there are no "yes" in the column I

Is it possible this code can develop to solve my existing daily

It appreciate anyone can help me develop this code.

 

[DanteAmor]

Try this.
I assume that the header row of the source sheet begins in row 1, if it is another row, then change the value 1.

Sub Copy_into_another_workbook()
  Dim w2 As Workbook, s1 As Worksheet, s2 As Worksheet, r1 As Long, r2 As Long, h As Long
  Application.ScreenUpdating = False
  Set s1 = ActiveSheet
  Set w2 = Workbooks("[COLOR=#ff0000]Destination[/COLOR].xlsx")  '[COLOR=#0000ff]This book ("destination") must be open[/COLOR]
  Set s2 = w2.Sheets("salesmanprofile")
  [B][COLOR=#ff0000]h = 1 [/COLOR] [/B]                                 '[COLOR=#0000ff]Header Row Number of source workbook[/COLOR]
  If s1.AutoFilterMode Then s1.AutoFilterMode = False
  If s2.AutoFilterMode Then s2.AutoFilterMode = False
  r1 = s1.Range("I" & Rows.Count).End(xlUp).Row
  r2 = s2.Range("B" & Rows.Count).End(xlUp).Row + 1
  If r2 < 5 Then r2 = 5
  s1.Range("A" & h & ":I" & r1).AutoFilter 9, "yes"
  s1.AutoFilter.Range.Range("B" & h + 1 & ":B" & r1).Copy s2.Range("B" & r2)
  s1.AutoFilter.Range.Range("D" & h + 1 & ":E" & r1).Copy s2.Range("D" & r2)
  s1.AutoFilter.Range.Range("H" & h + 1 & ":H" & r1).Copy s2.Range("H" & r2)
  s1.ShowAllData
  MsgBox "Done"
End Sub