VBA code to Automatically move specified cells in a row based on that rows list selection

Question

I need the below code to automatically move a row to another worksheet depending on the option I choose in that rows drop down list and I only want Columns A to S of that row to be moved, right now it moves the entire row. Please help.

Sub Automatically Move Members()

Dim Check As Range

Lastrow = Worksheets("Members to cut & past").UsedRange.Rows.Count
Lastrow2 = Worksheets("Holds").UsedRange.Rows.Count
Lastrow3 = Worksheets("Cancellations").UsedRange.Rows.Count
If Lastrow2 = 1 Then
Lastrow2 = 0
Else
End If

If Lastrow3 = 1 Then
Lastrow3 = 0
Else
End If

Do While Application.WorksheetFunction.CountIf(Range("N:N"), "Hold") > 0 Or
Application.WorksheetFunction.CountIf(Range("N:N"), "Cancelled") > 0

Set Check = Range("N2:N" & Lastrow)
For Each Cell In Check
    If Cell = "Hold" Then
        Cell.EntireRow.Copy Destination:=Worksheets("Holds").Range("A" &     lastrow2 + 1)
        Cell.EntireRow.Clear
        lastrow2 = lastrow2 + 1
   ElseIf If Cell = "Cancelled" Then
        Cell.EntireRow.Copy 
        Destination:=Worksheets("Cancellations").Range("A" & lastrow2 + 1)
        Cell.EntireRow.Clear
        Lastrow3 = lastrow3 + 1
   Else:
End If
Next
Loop

End Sub

score 0 · Answer 1 · answered Mar 03 '16 at 12:16

SOLVED Is there a way to make this code more efficient?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Check As Range
Dim RowN As Long

Lastrow = Worksheets("Members to cut & past").UsedRange.Rows.Count
lastrow2 = Worksheets("Holds").UsedRange.Rows.Count
lastrow3 = Worksheets("Cancellations").UsedRange.Rows.Count


Do While Application.WorksheetFunction.CountIf(Range("N:N"), "Hold") > 0 Or Application.WorksheetFunction.CountIf(Range("N:N"), "Cancelled") > 0
Set Check = Range("N2:N" & Lastrow)
For Each Cell In Check
    If Cell = "Hold" Then
    RowN = Cell.Row()
        Worksheets("Members to cut & past").Range(Cells(RowN, 1).Address & ":" & Cells(RowN, 14).Address).Copy Destination:=Worksheets("Holds").Range("A" & lastrow2 + 1)
        Worksheets("Members to cut & past").Range(Cells(RowN, 1).Address & ":" & Cells(RowN, 14).Address).Clear
        lastrow2 = lastrow2 + 1
   ElseIf Cell = "Cancelled" Then
   RowN = Cell.Row()
        Worksheets("Members to cut & past").Range(Cells(RowN, 1).Address & ":" & Cells(RowN, 14).Address).Copy Destination:=Worksheets("Cancellations").Range("A" & lastrow3 + 1)
        Worksheets("Members to cut & past").Range(Cells(RowN, 1).Address & ":" & Cells(RowN, 14).Address).Clear
        lastrow3 = lastrow3 + 1
   Else:
    End If
Next
Loop
End Sub

VBA code to Automatically move specified cells in a row based on that rows list selection

1 Answers1