Question

我需要以下代码自动将行移动到另一个工作表，具体取决于我在该行下拉列表中选择的选项，我只想移动该行的A到S列，现在它移动整行。请帮忙。

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

Answer 1

解决有没有办法让这个代码更有效率？

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代码根据行列表选择自动移动一行中的指定单元格

1 个答案: