http://www.excelforum.com/excel-programming-vba-macros/978346-vlookup-in-vba.htmlSub Purchasing()
Const fWhat As String = "purchasing"
Dim R As Range, fAdr As String, nR As Long, cutRng As Range, Ar As Range
With Sheets("Sheet1")
Set R = .Range("A:A").Find(fWhat, [A1], xlFormulas, xlPart, , , False)
If Not R Is Nothing Then
fAdr = R.Address
Set cutRng = R.Offset(-1, 0).Resize(4, .UsedRange.Columns.Count)
Do
Set R = .Range("A:A").FindNext(R)
If R Is Nothing Then Exit Do
If R.Address = fAdr Then Exit Do
Set cutRng = Union(cutRng, R.Offset(-1, 0).Resize(4, .UsedRange.Columns.Count))
Loop
End If
If Not cutRng Is Nothing Then
nR = 1
For Each Ar In cutRng.Areas
Ar.Cut Destination:=Sheets(.Index + 1).Range("A" & nR)
nR = Sheets(.Index + 1).Range("A" & Rows.Count).End(xlUp).Row + 1
Next Ar
End If
End WithOption Explicit
Sub Nearly()
Dim wbTarget As Workbook 'workbook where the data is to be pasted
Dim wbThis As Workbook 'workbook from where the data is to copied
Dim strName As String 'target workbook
Dim cn As String
'set to the current active workbook (the source book)
Set wbThis = ActiveWorkbook
'open a workbook that has same name as the sheet name
Set wbTarget = Workbooks.Open("C:\Users\Daisy\Desktop\Sheet1.xlsm") 'Put your path in the space noted
'select cell A1 on the target book
wbTarget.Sheets("test").Range("A1").Select
'clear existing values form target book
wbTarget.Sheets("test").Range("A1").EntireColumn.ClearContents
'activate the source book
wbThis.Activate
'clear any thing on clipboard to maximize available memory
Application.CutCopyMode = False
'copy the range from source book
wbThis.ActiveSheet.Range("A2:D13").copy
'paste the data on the target book ( for just values PasteSpecial xlValues )
wbTarget.Sheets("test").Cells(10, Columns.Count).End(xlToLeft).Offset(, 2).PasteSpecial xlPasteAll
'clear any thing on clipboard to maximize available memory
Application.CutCopyMode = False
'save the target book
wbTarget.Save
'IF close the workbook,change activate to close if you would like the pasted work book to close when complete
If wbTarget.Name <> "Sheet1" Then
wbTarget.Close
End If
'activate the source book again
wbThis.Activate
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing
End Sub