根据列AB中的单元格值将行从工作表1移动到工作表2并粘贴为值

我需要select性地将整个行从sheet1复制到sheet2。 我想使用“否”值列“AB”来select适用的行，然后将选定的行作为值复制到sheet2。 我能够创build代码来一次复制一行，但是希望所有的行都能够立即复制，而且我希望将复制的行作为值粘贴到sheet2中。 你能帮我吗？ 这是我正在使用的代码。

Option Explicit Sub Archive() Dim wc As Worksheet, wa As Worksheet Set wc = Sheets("sheet1") Set wa = Sheets("sheet2") Dim lr As Long lr = wc.Range("A" & Rows.Count).End(xlDown).Row Dim i As Long Application.ScreenUpdating = False For i = lr To 3 Step -1 'sheets all have headers that are 2 rows If wc.Range("AB" & i) = "No" Then wa.Range("A3").EntireRow.Insert wc.Range("A" & i & ":AG" & i).Cut wa.Range("A3") wc.Range("A" & i).EntireRow.Delete End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Archive Completed" End Sub 

Answer 1

除了@Jeeped提供的优雅解决scheme之外，以下VBAmacros不使用AutoFilterfunction：相反，它使用Excel VBA Range Unionfunction，可以将整套数据行从工作表wc到“存档”工作表wa立刻：

清单1.使用Range Union移动行的解决scheme

 Option Explicit Sub Archive() Dim wc As Worksheet, wa As Worksheet Dim lr As Long, I As Long Dim uR As Range Set wc = Sheets("Sheet1") Set wa = Sheets("Sheet2") lr = wc.Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For I = 3 To lr 'sheets all have headers that are 2 rows If wc.Range("AB" & I) = "No" Then If (uR Is Nothing) Then Set uR = Range(I & ":" & I) Else Set uR = Union(uR, Range(I & ":" & I)) End If End If Next I uR.Copy Destination:=wa.Range("A3") uR.EntireRow.Delete Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Archive Completed" End Sub 

您也可以find有用的扩展解决scheme，该解决scheme使用Range Areas属性显示已归档的行数（如清单2所示）：

清单2.展示存档行数的扩展解决scheme

 Option Explicit Sub Archive() Dim lr As Long, I As Long, rowsArchived As Long Dim unionRange As Range 'optional unprotect statement if Sheets("Sheet2") is protected Sheets("Sheet2").Unprotect Password:="myPassword" Application.ScreenUpdating = False With Sheets("Sheet1") lr = .Range("A" & .Rows.Count).End(xlUp).Row For I = 3 To lr 'sheets all have headers that are 2 rows If .Range("AB" & I) = "No" Then If (unionRange Is Nothing) Then Set unionRange = .Range(I & ":" & I) Else Set unionRange = Union(unionRange, .Range(I & ":" & I)) End If End If Next I End With rowsArchived = 0 If (Not (unionRange Is Nothing)) Then For I = 1 To unionRange.Areas.Count rowsArchived = rowsArchived + unionRange.Areas(I).Rows.Count Next I unionRange.Copy Destination:=Sheets("Sheet2").Range("A3") unionRange.EntireRow.Delete End If 'optional password-protection of Sheets("Sheet2") Sheets("Sheet2").Protect Password:="myPassword" Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Operation Completed. Rows Archived: " & rowsArchived End Sub 

注意 ：这两个解决scheme将保留原始行的格式。

根据您的附加问题：您可以使用以下VBA语句取消保护受保护的Excel Worksheet ：

 Sheets("Sheet2").Unprotect Password:="myPassword" 

这一个用相同的密码再次保护它：

 Sheets("Sheet2").Protect Password:="myPassword" 

作为另一个问题 ：请参阅修改的代码片段（清单2），其中演示了工作表保护/取消保护function的实现细节。

希望这可能有帮助。

Answer 2

使用Range.AutoFilter方法可快速隔离AB 列为否的行。

 Sub Archive() Dim wc As Worksheet, wa As Worksheet Application.ScreenUpdating = False Set wc = Sheets("sheet1") Set wa = Sheets("sheet2") With wc 'if autofilter active, turn it off If .AutoFilterMode Then .AutoFilterMode = False 'cells radiating out from A1 With .Cells(1, 1).CurrentRegion 'filter on AB=no .AutoFilter field:=28, Criteria1:="no" 'step off the header row With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) 'check if there are rows to copy If CBool(Application.Subtotal(103, .Columns(28))) Then 'insert rows at the destination wa.Range("A3").Resize(Application.Subtotal(103, .Columns(28)), 1).EntireRow.Insert 'copy the visible cells .SpecialCells(xlCellTypeVisible).Copy 'paste the values an formats With wa.Range("A3") .PasteSpecial Paste:=xlPasteValues .PasteSpecial Paste:=xlPasteFormats End With 'optionally delete the NO rows .EntireRow.delete End If End With End With 'turn off the autofilter If .AutoFilterMode Then .AutoFilterMode = False End With Application.ScreenUpdating = True MsgBox "Archive Completed" End Sub 

Answer 3

只是为了试验解决scheme，没有过滤，也没有循环通过单元格

如果“否”是“AB”列中唯一的值，

 Sub Archive2() Dim wc As Worksheet, wa As Worksheet Application.ScreenUpdating = False Set wc = Sheets("sheet01") Set wa = Sheets("sheet02") wc.Columns(28).SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeConstants).EntireRow.Copy wa.Range("A3").PasteSpecial Paste:=xlPasteValues wa.Range("A3").PasteSpecial Paste:=xlPasteFormats MsgBox "Archive Completed" End Sub 

否则需要一个“助手”栏来只抓住“AB”栏中的“No”（它使用第29栏作为“助手”一栏：如果干扰数据范围，只要在适当的位置进行移动）

 Option Explicit Sub Archive() Dim wc As Worksheet, wa As Worksheet Application.ScreenUpdating = False Set wc = Sheets("sheet01") Set wa = Sheets("sheet02") With wc With .Columns(28).SpecialCells(xlCellTypeConstants) .Offset(, 1).FormulaR1C1 = "=if(RC[-1] =""No"",1,"""")" .Offset(, 1).Value = .Offset(, 1).Value .Offset(, 1).SpecialCells(xlCellTypeConstants).EntireRow.Copy End With wa.Range("A3").PasteSpecial Paste:=xlPasteValues wa.Range("A3").PasteSpecial Paste:=xlPasteFormats .Columns(29).ClearContents End With wa.Columns(29).ClearContents MsgBox "Archive Completed" End Sub