Code to mimic vlookup

[Guest]

I am trying to create a macro that will do the following.

1). Look in a column on a one worksheet, going row by row, for a specified
text value.
2). If the value is found, then the value in the column to the left should
be copied.
3). The copied value should be pasted in a seperate worksheet in a specified
column.
4). The process should repeat until all matches in the first sheet have been
found, copied, and pasted in separate rows on the second worksheet.

The following is my ineffective code, at present. Any help is appreciated!

Sub Business_Populate()

Dim j As Long
Dim k As Long

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False


Sheets("Setup Form").Select
Range("d4:d33").Select
For j = Selection.Cells.Count To 1 Step -1
If Selection.Cells(j) = "Business" Then
Selection.Cells(j, "d").Offset(0, -3).Copy

End If
Next j

Sheets("Project Completion Costs").Select
Range("e10,e43").Select
For k = Selection.Cells.Count To 34 Step 1
If Cells(k, "e") = "" Then
Cells(k, "e").Select
ActiveSheet.Paste


End If
Next k

End With
End Sub

 

[Guest]

The following is according to my interpretation:

Sub Business_Populate()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim c As Range, cc As Range

Set ws1 = Sheets("Setup Form")
Set ws2 = Sheets("Project Completion Costs")
Set rng = ws1.Range("D433")
Set cc = ws2.Range("E43").End(xlUp)(2)
Application.ScreenUpdating = False
For Each c In rng.Cells
If LCase(Trim(c.Value)) = "business" Then
cc.Value = c(1, -2).Value 'Copies 3 columns to left. Change to
'c(1, 0) to copy 1 column to left if this is what you want.
Set cc = cc(2) 'Offsets 1 row down - i.e. cc(1) returns same cell.
End If
Next
Application.ScreenUpdating = True
End Sub

Regards,
Greg