Question

以下代码应用过滤器，并在将某些过滤器应用于表后选择B列中的前10个项目。我一直在使用它进行许多不同的过滤选择，但我遇到了一个我的过滤器组合的问题。

我发现当过滤后B列中只有一个项目时，它不会复制那个单元格 - 而是复制整行，看起来是一个奇怪的选择。

当我手动向此过滤器添加一个项目（共2个）时，它会将其复制好。当只有一个项目时，有关为什么此代码不起作用的任何想法？

Sub top10()

Dim r As Range, rC As Range
Dim j As Long

'Drinks top 10
Worksheets("OLD_Master").Columns("A:H").Select
Selection.sort Key1:=Range("H1"), Order1:=xlDescending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal

Worksheets("OLD_Master").Range("A:H").AutoFilter Field:=4, Criteria1:=Array(     _
    "CMI*"), Operator:= _
    xlFilterValues
Worksheets("OLD_Master").Range("A:H").AutoFilter Field:=5,   Criteria1:="Drinks"

Set r = Nothing
Set rC = Nothing
j = 0

Set r = Range("B2", Range("B" &     Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

For Each rC In r
    j = j + 1
    If j = 10 Or j = r.Count Then Exit For
Next rC

Range(r(1), rC).SpecialCells(xlCellTypeVisible).Copy

Worksheets("For Slides").Range("P29").PasteSpecial
Worksheets("OLD_Master").ShowAllData

End Sub

Answer 1

罗里有用地指出：

如果您只将Specialcells应用于一个单元格，它实际上适用于工作表的整个使用范围。

现在我们知道问题是什么，我们可以避免它！您使用SpecialCells的代码行：

Set r = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

相反，首先设置范围，测试它是否只包含一个单元格，然后继续......

Set r = Range("B2", Range("B" & Rows.Count).End(xlUp))
' Check if r is only 1 cell
If r.Count = 1 Then
    r.Copy
Else ' Your previous code
    Set r = r.SpecialCells(xlCellTypeVisible)
    For Each rC In r
        j = j + 1
        If j = 10 Or j = r.Count Then Exit For
    Next rC
    Range(r(1), rC).SpecialCells(xlCellTypeVisible).Copy
End If

注意，您假设甚至一个行仍然可见。如果没有可见数据，.End(xlUp)可能会选择第1行，您可能想要先检查哪一行也是第一行！

除此之外：你真的应该完全符合你的范围，而不是

 Set r = Range("B2")

你应该使用

Set r = ThisWorkbook.Sheets("MySheet").Range("B2")

这将为您节省一些令人困惑的错误。您可以使用快捷方式，例如使用With块保存重复或声明工作表对象。

' using With blocks
With ThisWorkbook.Sheets("MySheet")
    Set r = .Range("B2")
    Set s = .Range("B3")
    ' ...
End With

' Using sheet objects
Dim sh as Worksheet
Set sh = ThisWorkbook.Sheets("MySheet")
Set r = sh.Range("B2")

Answer 2

感谢@Rory

Specialcells

不适用于所选的一个单元格。通过执行以下操作进行改编：

...

For Each rC In r
    j = j + 1
    If j = 10 Or j = r.Count Then Exit For
Next rC

If j = 1 Then
    Range(r(1), rC).Copy
Else
    Range(r(1), rC).SpecialCells(xlCellTypeVisible).Select
End If

Worksheets("For Slides").Range("P29").PasteSpecial
Worksheets("OLD_Master").ShowAllData

End Sub

过滤后VBA选择可见单元格

2 个答案: