vba - Excel - 根据列中的数据将指定列复制到新工作表

Question

我需要以下帮助：

我需要为 G 列中的任何数据过滤范围 A9 - A32。然后我需要复制数据，但只有 A - E & G 列到工作表 2。然后删除过滤的数据并返回到未过滤的视图。

我尝试了以下方法但没有成功：

Dim shSrc As Worksheet
Dim shDst As Worksheet
Dim rSrc As range
Dim rDst As range
Dim range
Dim numCol As Long ' number of columns to copy

On Error GoTo EH

range = ("A:E,G:G")

' select source and dest sheets
Set shSrc = ActiveWorkbook.Worksheets("Active Snag List")
Set shDst = ActiveWorkbook.Worksheets("Snag History")

' Select initial rows
Set rSrc = shSrc.Cells(9, 7)
Set rDst = shDst.Cells(2, 1)

' loop over source
Do While rSrc <> ""
    ' Test Source row, Qty = 0 and Name is not blank
    With rSrc
        If .Offset(0, 2) = 0 And .Value <> "" Then
            'Copy
            .Resize(1, range).Copy rDst.Resize(1, range)
            Set rDst = rDst.Offset(1, 0)
        End If
    End With
    Set rSrc = rSrc.Offset(1, 0)
Loop
Exit Sub
EH:
MsgBox "Error " & Err.Description

先感谢您！

Answer 1

要使您的代码正常工作，请将此IF部分替换为

        If .Offset(0, 2) = 0 And .Value <> "" Then
            'Copy
            'Cells A:E
            rDst.Resize(1, 5).Value = .EntireRow.Cells(1, 1).Resize(1, 5).Value
            ' Cell G
            rDst.Offset(0, 6).Value = .Value

            Set rDst = rDst.Offset(1, 0)
        End If

Answer 2

为什么不使用自动过滤器而不是循环遍历单元格？它会让我快得多。请参阅此示例。

代码（尝试和测试）

Option Explicit

Sub Sample()
    Dim shSrc As Worksheet, shDst As Worksheet
    Dim rDst As range, rng As range, rngtocopy As range
    Dim lastrow As Long

    On Error GoTo EH

    '~~> Select source and dest sheets
    Set shSrc = ThisWorkbook.Worksheets("Active Snag List")
    Set shDst = ThisWorkbook.Worksheets("Snag History")

    '~~> Select initial rows
    Set rDst = shDst.Cells(2, 1)

    With shSrc
        '~~> Remove any filters
        .AutoFilterMode = False

        '~~> Get the last row of Col G
        lastrow = .range("G" & .Rows.Count).End(xlUp).Row

        With .range("A8:G" & lastrow)
            '~~> Filter G Col for non blanks
            .AutoFilter Field:=7, Criteria1:="<>"
            '~~> Get the offset(to exclude headers)
            Set rng = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
            '~~> Remove Col F from the resulting range
            Set rngtocopy = Union(shSrc.range(Replace(rng.Address, "G", "E")), _
            shSrc.range(Replace(rng.Address, "A", "G")))
            '~~> Copy cells to relevant destination
            rngtocopy.Copy rDst
            '~~> Delete the filtered results
            rng.EntireRow.Delete
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With

    Exit Sub
EH:
    MsgBox "Error " & Err.Description
End Sub

快照

宏运行前的工作表 1

宏运行后的工作表 2

宏运行后的工作表 1