vba 根据列值移动行
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/14407985/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Moving rows based on column values
提问by tehbrando
I need to scan through all of the rows in the "Master" worksheet, find any cells with the value "Shipped" in the column "Status", then cut and paste each entire row to another sheet. The pasted rows need to be placed after the last row also.
我需要扫描“主”工作表中的所有行，在“状态”列中找到值为“已发货”的任何单元格，然后将每一整行剪切并粘贴到另一张工作表中。粘贴的行也需要放在最后一行之后。
I found thispost (pasted below) which I slightly modified to delete rows successfully. But I can not figure out how to move rows instead. Should I try an entirely new method?
我找到了这篇文章（粘贴在下面），我稍微修改了它以成功删除行。但我不知道如何移动行。我应该尝试一种全新的方法吗？
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
I do not know VBA. I only kind of understand it because of my brief programming history. I hope that is okay and thank you for any help.
我不知道 VBA。我只是因为我简短的编程历史才有点理解它。我希望没关系，并感谢您的任何帮助。
采纳答案by tehbrando
I ended up combining the code I was originally using (found here) with an AutoFilter macro (found here). This is probably not the most efficient way but it works for now. If anyone knows how I can use only the For Loop or only the AutoFilter method that would be great. Here is my code. Any edits I should make?
我最终将我最初使用的代码（在此处找到）与 AutoFilter 宏（在此处找到）结合使用。这可能不是最有效的方法，但目前有效。如果有人知道我如何只使用 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
Hope it helps someone!
希望它可以帮助某人！
回答by Maudise
There's a couple of ways you could do it, can you add a filter to the top columns, filter by the value of 'Shipped'? Does it need to be copy and pasted into a new sheet?
有几种方法可以做到，您可以在顶部列添加过滤器，按“已发货”的值进行过滤吗？是否需要复制并粘贴到新工作表中？
It's not the most concise code but it might work
这不是最简洁的代码，但它可能有效
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:$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
I haven't tried it so it might need updating
我没试过所以可能需要更新
