Solved: Find a cell, copy, paste and delete

[vadim]

hi,

I am looking for a code to do the following:

I need to find a cell which contains sth the user is writing,
then I need to copy every thing what is in the row of this cell and paste it in another worksheet (eg Sheet3) but in the other worksheet the columns have different meanings so I have to do it cell by cell.
Afterwards the whole row with the cell found at the beginning has to be deleted.

The first part is working:
[VBA]Sub searching()
Sheets("NewP").Select
NumPro = InputBox("Enter Project Number")
Cells.Find(What:=NumPro, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
x = Selection.Address
End Sub
[/VBA]
Problem is, that "x" is a read-only and I cannot work with it further...

So I either would like to get the row number somehow if it is possible or solve it differently..


MANY Thanks in advance
Vadim

[Bob Phillips]

[vba]

Sub searching()
Sheets("NewP").Select
NumPro = InputBox("Enter Project Number")
Set cell = Cells.Find(What:=NumPro, _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cell Is Nothing Then

'adjust these cells accordingly
Worksheets("Sheet3").Range("C1").Value = Cells(cell.Row, "A").Value
Worksheets("Sheet3").Range("D1").Value = Cells(cell.Row, "E").Value
'etc.
cell.EntireRow.Delete
End If
End Sub
[/vba]

[vadim]

Thanks!

Works perfect.
My additional problem (forgot to mention) is that in "Sheet3" I have to paste things in a row which number is not predefined before. Means that I only know that it is the row which is above a cell with a name "LastCell"...
How should I address it in the context:

[VBA] Worksheets("Sheet3").Range("C1").Value = Cells(cell.Row, "A").Value[/VBA]

[MaximS]

you might try this:

[vba]
Sub searching()
Sheets("NewP").Select
NumPro = InputBox("Enter Project Number")

With Worksheets("Sheet3")
Set LastCell = .Cells.Find(What:="LastCell", _
After:=[A1], _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

y = LastCell.Row - 1

End With


Set cell = Cells.Find(What:=NumPro, _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cell Is Nothing Then

'adjust these cells accordingly
Worksheets("Sheet3").Range("C" & y).Value = Cells(cell.Row, "A").Value
Worksheets("Sheet3").Range("D" & y).Value = Cells(cell.Row, "E").Value
'etc.
cell.EntireRow.Delete
End If
End Sub
[/vba]

[vadim]

Thanks. U'm debugging now Will come back for more

[vadim]

So far the copying works perfectly (do it now in the 8th row...)

I would like additionally to check first whether the entered value exists and therefore have the else function built in. but it doesn't work

[vba]
Sub CopyingWon()
' pasting new line in the 8th row
Sheets("Won").Select
Rows("8:8").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
' searching for a project
Sheets("NewOpenPro").Select
numpro = InputBox("Please enter the Code", "Selection", "XXX")
Set cell = Cells.Find(What:=numpro, _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

If Not cell Is Nothing Then

Worksheets("Won").Range("A8").Value = Cells(cell.Row, "A").Value
Worksheets("Won").Range("B8").Value = Cells(cell.Row, "B").Value
Worksheets("Won").Range("C8").Value = Cells(cell.Row, "C").Value
Worksheets("Won").Range("D8").Value = Cells(cell.Row, "D").Formula

cell.EntireRow.Delete

Else
MsgBox ("Please enter an existing Code")
Sheets("Won").Select
Rows("8:8").Select
Selection.EntireRow.Delete
End If

End Sub
[/vba]
THANKS!