フィルタリング後に可視セルを選択するVBA

Question

次のコードは、フィルタを適用し、一部のフィルタがテーブルに適用された後で列Bの上位10個の項目を選択します。私はこれをさまざまなフィルタリングされた選択に使用してきましたが、私は自分のフィルタの組み合わせの1つに問題を見つけました。

フィルタリング後にB列に項目が1つしかない場合、その1つのセルはコピーされず、行全体がコピーされ、奇妙な選択と思われます。

このフィルタに1つ以上のアイテムを手動で追加すると（合計2）、それが正常にコピーされます。アイテムが1つしかないときにこのコードが機能しない理由についてのアイデアはありますか？

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 = ThisWorkbook.Sheets("MySheet").Range("B2") 

を使用する必要があり、あなたの範囲を修飾する、すなわち、代わりの

Set r = 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

は、選択された一つのセルでは動作しません

Specialcells 

を@Roryをお願い致します。

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