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

我在子片段中添加了托馬斯代碼，以查看自動過濾器是否正常工作並出現錯誤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方法（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