Search and copy data (Macro)

[bestman21]

Hi,
Please check the below code I need to change reading source from Sheets("Data")
to external workbook located in C:\Data.xlsx
Also this MsgBox "Search item not found" always showing to me even data copied well, and looks like little slow.
Attached file too, to run Macro shortcut key: Ctrl+a



[VBA]
Sub test1()
Application.ScreenUpdating = False
'Search
Dim Search As String
Dim i As String
On Error GoTo ErrorCatch
Search = Range("A1").Value
Sheets("Data").Select
Columns("A:A").Select
Selection.Find(What:=Search, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Select
'Copy record to Entry
ActiveCell.Offset(0, 1).Range("A1:E1").Select
i = 1
Sheets("Entry").Select
Range("D4").Select
Sheets("Data").Select
Do
If ActiveCell <> "" Then
Selection.Copy
Sheets("Entry").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveCell.Offset(2, 0).Select

ActiveCell.Offset(2, 0).Select
Else
ActiveCell.Offset(0, 1).Select
End If
Loop Until i = 5
'Move to second column
Sheets("Entry").Select
Range("E4").Select
Sheets("Data").Select
i = 1
Do
If ActiveCell <> "" Then
Selection.Copy
Sheets("Entry").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveCell.Offset(2, 0).Select

ActiveCell.Offset(2, 0).Select
Else
ActiveCell.Offset(0, 1).Select
End If
Loop Until i = 5
'Delete old record
Sheets("Data").Select
Selection.ClearContents
Sheets("Entry").Select
Exit Sub
ErrorCatch:
Sheets("Entry").Select
MsgBox "Search item not found"

End Sub
[/VBA]