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