copy row based on match and multiple criteria

[franky]

Hi all.

I need a formula or function that would look at a value in a cell,
compare it to a whole column on another sheet

If a match exists then I need the code to look say 10 columns further
along in the same row at the cell value.

If this value is equal to say "blue" then I want the whole row to be
copied to the sheet "Blue" if the value is say "red" then I want the
whole row to be copied to sheet red.

If no match is found then nothing should happen.

 

[Mike H.]

This code will do exactly what I understood you to ask, but I seriously doubt
that that is really what you wanted because it makes no sense to me why you'd
want to do what this is doing, but here goes:

Option Base 1
Option Explicit

Sub Doit()
Dim DataArray(5000, 3) As Variant
Dim Fnd As Double
Dim Y As Double
Dim X As Double


Sheets("sheet1").Select
X = 1
Do While True
If Cells(X, 1).Value = Empty Then Exit Do
Fnd = Fnd + 1
DataArray(Fnd, 1) = Cells(X, 1).Value
DataArray(Fnd, 2) = X
X = X + 1
Loop

Sheets("sheet2").Select
X = 1
Do While True
If Cells(X, 1).Value = Empty Then Exit Do
For Y = 1 To Fnd
If Cells(X, 1).Value = DataArray(Y, 1) Then
DataArray(Y, 3) = Cells(X, 10).Value 'placing "red" or "blue"
in element #3 so I can copy to that sheet
Exit For
End If
Next
X = X + 1
Loop

'now go back to sheet1 and copy the rows that have information that needs
copying...
Sheets("sheet1").Select
For X = 1 To Fnd
If Len(DataArray(X, 3)) > 0 Then
Rows(DataArray(X, 2) & ":" & DataArray(X, 2)).Select
Selection.Copy
Sheets(DataArray(X, 3)).Select
Range("A65000").End(xlUp).Select 'this is a row with data, this row
+1 is empty!
Cells(ActiveCell.Row + 1, 1).Select
ActiveSheet.Paste
End If
Next

End Sub