Solved: Posting rows to another sheet some copy, other move

[khaledocom]

Hi all,

I have a workbook contains three sheets "Data, Demo and Relc"
Based on values in some field I want a VBA code to move some of the subject row and copy the remaining part of it to the other sheet.

Please open the attached file for details.

Thankful for your help and support.

[Xrull]

Hi Khaledocom,

If I understand you correctly, if you type the word "Relc" the entire row must be copied to the sheet Relc and if you type "Deo" it must be copied to the Demo sheet.

Paste the following code in the sheet code window.

[VBA]Private Sub Worksheet_Change(ByVal Target As Range)
'/ Poster's name: Khaledocom
'/ Date: 02/28/2012
'/ Link: http://www.vbaexpress.com/forum/showthread.php?t=41150
'/ Source sheet
Dim wksDt As Worksheet
Set wksDt = Sheets("Data")
'/ A receiving sheet
Dim wksDo As Worksheet
Set wksDo = Sheets("Demo")
'/ A receiving sheet
Dim wksRc As Worksheet
Set wksRc = Sheets("Relc")

'/ Determing the last row in column R 'Column 18
Dim lngRow As Long
lngRow = wksDt.Cells(Rows.Count, 18).End(xlUp).Row

If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub

If Not Intersect(Target, Range("R4:R" & lngRow)) Is Nothing Then
If UCase(Target.Cells.Value) = "DEO" Then
wksDt.Range(Cells(Target.Cells.Row, 1), Cells(Target.Cells.Row, 18)).Copy
wksDo.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
ElseIf UCase(Target.Cells.Value) = "RELC" Then
wksDt.Range(Cells(Target.Cells.Row, 1), Cells(Target.Cells.Row, 18)).Copy
wksRc.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
End If
End If

End Sub[/VBA]

I've also attached a file with the code.

Regards,
Xrull

[khaledocom]

Thanks a lot Xrull
But I need it to clear the range("F:R") after posting its values to other sheets.

[Xrull]

Khaledocom:

Replace the code in the Data sheet's VBE with this one.
[VBA]Private Sub Worksheet_Change(ByVal Target As Range)
'/ Poster's name: Khaledocom
'/ Date: 02/28/2012
'/ Link: http://www.vbaexpress.com/forum/showthread.php?t=41150
'/ Source sheet
Dim wksDt As Worksheet
Set wksDt = Sheets("Data")
'/ A receiving sheet
Dim wksDo As Worksheet
Set wksDo = Sheets("Demo")
'/ A receiving sheet
Dim wksRc As Worksheet
Set wksRc = Sheets("Relc")

'/ Determing the last row in column R 'Column 18
Dim lngRow As Long
lngRow = wksDt.Cells(Rows.Count, 18).End(xlUp).Row

If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub

If Not Intersect(Target, Range("R4:R" & lngRow)) Is Nothing Then
If UCase(Target.Cells.Value) = "DEO" Then
wksDt.Range(Cells(Target.Cells.Row, 1), Cells(Target.Cells.Row, 18)).Copy
wksDo.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
wksDt.Range(Cells(Target.Cells.Row, 6), Cells(Target.Cells.Row, 18)).ClearContents
ElseIf UCase(Target.Cells.Value) = "RELC" Then
wksDt.Range(Cells(Target.Cells.Row, 1), Cells(Target.Cells.Row, 18)).Copy
wksRc.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
wksDt.Range(Cells(Target.Cells.Row, 6), Cells(Target.Cells.Row, 18)).ClearContents
End If
End If

End Sub[/VBA]

Whenever you are posting a question, please specify all the tasks that a macro is required to do. It will save you a lot of time.

Regards,
Xrull

[khaledocom]

Thanx a lot, It's really gr8.

[mdmackillop]

For the benefit of non-english speakers, please don't use text speak.