Transfer selected rows to sheet

--------------------------------------------------------------------------------

Dim MyValue As Variant
Dim FromSheet As Worksheet
Dim LookupColumn As Integer
Dim FromRow As Long
Dim FromColumn As Integer
'-
Dim ToSheet As Worksheet
Dim StartRow As Long
Dim LastRow As Long
Dim ActiveColumn As Integer
Dim ReturnColumnNumber
Dim ToRow As Long
Dim FoundCell As Object

'================================================= ============
'- MAIN ROUTINE
'================================================= ============
Sub DO_LOOKUP()
Application.Calculation = xlCalculationManual
'----------------------------------------------------------
'- LOOKUP SHEET [**AMEND AS REQUIRED**]
Set FromSheet = Workbooks("Book1.xls").Worksheets("MD")
LookupColumn = 2 ' look for match here
FromColumn = 2 ' return value from here
'-----------------------------------------------------------
'- ACTIVE SHEET
Set ToSheet = ActiveSheet
ActiveColumn = ActiveCell.Column
StartRow = ActiveCell.Row
'-------------------------------------------------------------
'- COMMENT OUT UNWANTED LINE, UNCOMMENT THE OTHER
'- ..............................[** FOR MULTIPLE ROWS **]
LastRow = ToSheet.Cells(65536, ActiveColumn).End(xlUp).Row
'-
'- ..............................[** FOR A SINGLE VALUE **]
' LastRow = ActiveCell.Row
'-------------------------------------------------------------
'- COLUMN NUMBER TO PUT RETURNED VALUE [**AMEND AS REQUIRED**]
ReturnColumnNumber = 2 ' column number
'-------------------------------------------------------------
'- loop through each row (which may be only 1)
For ToRow = StartRow To LastRow
MyValue = ToSheet.Cells(ToRow, ActiveColumn).Value
FindValue
Next
'-------------------------------------------------------------
'- finish
MsgBox ("Done")
Application.Calculation = xlCalculationAutomatic
End Sub
'== END OF PROCEDURE ==================================================
==

'=================================================
=======================
'- FIND VALUE
'=================================================
=======================
Private Sub FindValue()
' Dim VendMat As String
' Dim matDesc As String
' Dim startDate As String
' Dim BUN As String
Set FoundCell = _
FromSheet.Columns(LookupColumn).Find(MyValue, LookIn:=xlValues)
If FoundCell Is Nothing Then
MsgBox ("Material No. " & MyValue & " not found in Master List.")
'Paste this value to MD
'-----
' VendMat = Sheets("Sheet1").Select
' VendMat = Range("C65536").End(xlUp).Offset(0, 0).Select
'VendMat = Selection.Copy
'------

Sheets("MD").Select
Range("B:B").Select

Range("B65536").End(xlUp).Offset(1, 0).Select
IsEmpty (ActiveCell)
ActiveCell = MyValue

' Sheets("MD").Select
' Range("C:C").Select
' Range("C65536").End(xlUp).Offset(1, 0).Select
' IsEmpty (ActiveCell)
' ActiveCell.Select = VendMat
' ActiveCell = VendMat

'---------------------------------------------

Else
FromRow = FoundCell.Row
'- transfer additional data.
ToSheet.Cells(ToRow, ReturnColumnNumber).Value = _
FromSheet.Cells(FromRow, FromColumn).Value
End If
End Sub
'

This works fine in detecting and copying the new material number
accross to the master data sheet, but now i want it to copy the row in
which the new material number is located as there is other information
that goes with so it doesn't have to be manually typed in.

TIA


--
vect98
------------------------------------------------------------------------
vect98's Profile: http://www.excelforum.com/member.php...o&userid=26365
View this thread: http://www.excelforum.com/showthread...hreadid=399715