Macro for this Post
' http://www.excelfox.com/forum/showth...ll=1#post13058 http://www.excelfox.com/forum/showth...3058#post13058


Code:
'   http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste-by-VBA-based-on-criteria?p=13058&viewfull=1#post13058     http://www.excelfox.com/forum/showthread.php/2454-copy-and-paste-by-vba?p=13058#post13058
Sub Step10()
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook   '                           If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks,  Workbooks(" ")
 Set Wb1 = Workbooks("1.xlsx")         '          Workbooks("sample1.xlsx")   '                                                 Set Wb1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls")                ' w1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")           ' change the file path   If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks,  Workbooks(" ")
 Set Wb2 = Workbooks("2.xlsx")         '          Workbooks("sample2.xlsx")   '                                                 Set Wb2 = Workbooks.Open(ThisWorkbook.Path & "\FundsCheck.xlsb")      ' w2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\FundsCheck.xlsb") ' change the file path      If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks,  Workbooks(" ")
Dim Ws1 As Worksheet, Ws2 As Worksheet
 Set Ws1 = Wb1.Worksheets.Item(1)      '                                                                            Set Ws1 = Wb1.Worksheets("anything")  '     sheet name can be anything
 Set Ws2 = Wb2.Worksheets.Item(1)      '                                                                          ' Set Ws2 = Wb2.Worksheets("anything")
Dim Lr1 As Long, Lc1 As Long
 Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row      '   http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466      Making Lr dynamic ( using rng.End(XlUp) for a single column. )
 Let Lc1 = Ws1.Cells.Item(2, Ws1.Columns.Count).End(xlToLeft).Column
Rem 2 Data ranges
Dim arrOut() As String
 ReDim arrOut(1 To Lr1 - 1, 1 To 2) ' A 2 column array of as many rows as data in 1.xlsx  We may not need all the rows
Dim rngIn As Range
 Set rngIn = Ws1.Range(Ws1.Range("A1"), Ws1.Cells.Item(Lr1, Lc1))
Rem 3 Go through rows and columns  in input data range
Dim Rws As Long
    For Rws = 2 To Lr1 ' Go through rows in input data range
    Dim rngInRws As Range
     Set rngInRws = rngIn.Rows.Item(Rws) ' consider a row in the data range
    Dim Clms As Long ' go through columns in each row
        For Clms = 2 To Lc1 ' considering each column in the row under consideration
            If rngInRws.Cells.Item(Clms).Interior.Color = 65535 And rngInRws.Cells.Item(Clms).Value >= 5 Then ' ...if yellow highlighted colour data is greater than 5 or equal to 5 then
            Dim RwOut As Long ' a row in output array
             Let RwOut = RwOut + 1 ' a next new row in output array
             Let arrOut(RwOut, 1) = rngInRws.Cells.Item(1)              ' The value in the first cell in the row under consideration is put in first column in output array
             Let arrOut(RwOut, 2) = rngInRws.Cells.Item(Clms).Value     ' The value in the highlighted cell in the row under consideration is put in the second column of the output array
            Else
            ' Do nothing
            End If
        Next Clms
    Next Rws
Rem 4 Output result
 Let Ws2.Range("A1:B" & Lr1 - 1 & "").Value = arrOut() ' A range of the dimensions of the output array has its values assigned to the values in the output arry
End Sub