Question

我需要有选择地将整行从sheet1复制到sheet2。我想使用＆＃34; No＆＃34;价值栏＆＃34; AB＆＃34;选择适用的行，然后将选定的行复制到sheet2作为值。我能够创建一次复制一行的代码，但希望所有行一次复制而不是循环，我希望将复制的行作为值粘贴到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

使用Range.AutoFilter Method快速隔离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 2

除了@Jeeped提供的优雅解决方案之外，以下VBA宏不使用AutoFilter功能：它使用Excel VBA Range Union功能，可以移动从工作表wc到“归档”工作表wa的整个数据行一次：

清单1.使用Range Union

移动行的解决方案

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

您可能还会发现扩展解决方案很有用，它使用Range Areas属性显示已归档行的数量，如下所示（清单2）：

清单2.显示已归档行数的扩展解决方案

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

注意：两种解决方案都会保留原始行的格式。

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

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

并使用相同的密码再次保护它：

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

根据您的另一个问题：请参阅修改后的代码段（清单2），其中演示了Worksheet保护/取消保护功能实现的详细信息。

希望这可能会有所帮助。

Answer 3

只是尝试没有过滤的解决方案，也不需要循环遍历单元格

如果“否”是“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”列中仅捕获“否”（它使用第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

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

3 个答案: