SpecialCells(xlCellTypeVisible)

Question

我有 15 列数据，行数从 400 到 1000，并且我应用了过滤器，我热衷于仅将 D 列和 J 列的可见单元格复制到不同的工作表上，但通过转置粘贴特殊值进入 D6 范围。

我使用了下面的方法，但它只是复制两个可见行，而不是根据代码复制每一行，就像过去对我修改后运行的其他工作表所做的那样。问题可能是我在一个宏中运行了三个或四个进程。

我很想知道如何修改此代码，以便将 d 列和 j 列可见单元格复制到不同的工作表中，不包括标题

那么我对代码的立场是什么，它运行并应用过滤器，但未能复制宏的这个特定部分的所有行，其次，我很想知道如何修改它，所以它只复制上述列 D 和 J 不包括标题，并且仅复制可见单元格以通过转置粘贴特殊值。

Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
Report.Range("D6").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True


Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long
    Dim rngToCopy As Range, rRange As Range

    Set ws = Sheets("Sheet1")

    With ws
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        Set rRange = .Range("A1:A" & lRow)

        '~~> Remove any filters
        .AutoFilterMode = False

        With rRange 'Filter, offset(to exclude headers) and copy visible rows
            .AutoFilter Field:=1, Criteria1:="<>"
            Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        '~~> Remove any filters
        .AutoFilterMode = False

        rngToCopy.Copy

        '
        '~~> Rest of the Code
        '
    End With
End Sub

我在子片段中添加了 thomas 代码，以查看自动过滤器是否正常工作并收到错误 91

Sub Filter()
Dim Sheetx As Worksheet
Dim rngToCopy As Range, rRange As Range

With Sheetx

Set rRange = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))

With rRange

.AutoFilter Field:=11, Criteria1:="30"
.AutoFilter Field:=4, Criteria1:="1"
.AutoFilter Field:=2, Criteria1:="=*1", _
Operator:=xlAnd


With .SpecialCells(xlCellTypeVisible)

Set rngToCopy = Union(.Offset(0, 3), .Offset(0, 9))

End With

rngToCopy.Copy

End With
End With

End Sub

Answer 1

我们可以使用Union 和Range.Offset 将单元格连接在一起定义范围。

MSDN: Application.Union Method (Excel)

返回两个或多个范围的并集。

---

Sub Sample()

    Dim lRow As Long
    Dim rngToCopy As Range, rRange As Range


    With Sheets("Sheet1")

            With .Range("A1").CurrentRegion
                .AutoFilter Field:=11, Criteria1:="=30"
                .AutoFilter Field:=4, Criteria1:="=1"
                .AutoFilter Field:=2, Criteria1:="=1", _
                Operator:=xlAnd

                On Error Resume Next
                Set rngToCopy = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0

                If rngToCopy Is Nothing Then
                    MsgBox "SpecialCells: No Data", vbInformation, "Action Cancelled"
                    Exit Sub
                End If


                Set rngToCopy = Intersect(rngToCopy, .Range("B:B,H:H"))

                 If rngToCopy Is Nothing Then
                    MsgBox "Intersect: No Data", vbInformation, "Action Cancelled"
                    Exit Sub
                End If
        End With
    End With

    rngToCopy.Copy


    Sheets("Sheet2").Range("C6").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=True

End Sub