Question

我需要扫描“Master”工作表中的所有行，在“Status”列中找到值为“Shipped”的所有单元格，然后将每一行剪切并粘贴到另一个工作表。粘贴的行也需要放在最后一行之后。

我发现this帖子（粘贴在下面），我稍加修改后成功删除了行。但我无法弄清楚如何移动行。我应该尝试一种全新的方法吗？

Sub DeleteRows()

    Dim rng As Range
    Dim counter As Long, numRows as long        

        With ActiveSheet
           Set rng = Application.Intersect(.UsedRange, .Range("C:C"))
        End With
        numRows = rng.Rows.Count

        For counter = numRows to 1 Step -1 
         If Not rng.Cells(counter) Like "AA*" Then
            rng.Cells(counter).EntireRow.Delete
         End If
       Next

End Sub

我不知道VBA。由于我简短的编程历史，我只是理解它。我希望没关系，谢谢你的帮助。

Answer 1

您可以通过多种方式进行操作，是否可以在顶部列中添加过滤器，按“已发货”值进行过滤？是否需要复制并粘贴到新表中？

这不是最简洁的代码，但可能有效

    sub Shipped_filter()
dim wsSheet as worksheet
dim wsOutputSheet as worksheet
dim BottomRow as integer

Set wsSheet = worksheets("Sheet1") 'change to the sheet name
set wsOutputSheet = worksheets("Sheet2") 'change to the sheet name

'*****************************
'* Delete old data on Sheet2 *
'*****************************
wsoutputsheet.activate
Activesheet.cells.clearall

wsSheet.range("A1").select
selection.autofilter

BottomRow = wsSheet.range("A90000").end(xlup).row ' or another column you guarantee will always have a value

activesheet.range("$A$1:$Z$"&BottomRow).AutoFilter field:=1, Criteria1:="Shipped" ' change field to whatever column number Status is in

'********************************
'* Error trap in case no update *
'********************************

if activesheet.range("A90000").end(xlup).row = 1 then
 msgbox("Nothing to ship")
exit sub
end if


wsSheet.range("A1:Z"&Bottomrow).select
selection.copy

wsOutputSheet.range("A1").select
selection.pastespecial Paste:=xlpastevalues
application.cutcopymode = false

msgbox('update complete')

end sub

我没有尝试过，所以可能需要更新

Answer 2

我最终将我最初使用的代码（found here）与AutoFilter宏（found here）结合起来。这可能不是最有效的方法，但现在可以使用。如果有人知道我怎么只能使用For循环或只使用AutoFilter方法那么棒。这是我的代码。我应该做什么编辑？

Sub DeleteShipped()

Dim lastrow As Long
Dim rng As Range
Dim counter As Long, numRows As Long

    With Sheets("Master")

        'Check for any rows with shipped
        If .Range("R:R").Find("Shipped", , xlValues, xlWhole, , , False) Is Nothing Then
            MsgBox "No shipped plates found. ", , "No Rows Moved": Exit Sub
        Else

            Application.ScreenUpdating = False

            'Copy and paste rows
            lastrow = .Range("A" & Rows.Count).End(xlUp).Row
            lastrow2 = Worksheets("ShippedBackup").Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Range("A1:U" & lastrow).AutoFilter field:=18, Criteria1:="Shipped"
            .Range("A2:U" & lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
            Sheets("ShippedBackup").Range("A" & lastrow2).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
            .ShowAllData

            'Delete rows with shipped status
            Set rng = Application.Intersect(.UsedRange, .Range("R:R"))
            numRows = rng.Rows.Count

            For counter = numRows To 1 Step -1
             If rng.Cells(counter) Like "Shipped" Then
                rng.Cells(counter).EntireRow.Delete
             End If
            Next

            MsgBox "All shipped records have been moved to the ""ShippedBackup"" worksheet.", , "Backup Complete"

        End If
End With

希望它有所帮助！

根据列值移动行

2 个答案: