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 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