VBA Auswählen von sichtbaren Zellen nach dem Filtern

Question

Der folgende Code wendet Filter an und wählt die obersten 10 Elemente in Spalte B aus, nachdem einige Filter auf die Tabelle angewendet wurden. Ich habe dies für viele verschiedene gefilterte Auswahl verwendet, aber ich stieß auf ein Problem mit einer meiner Filterkombinationen.

Ich fand, dass, wenn es nur ein Element in der Spalte B nach dem Filtern gibt, es kopiert nicht die eine Zelle - stattdessen kopiert es die gesamte Zeile und scheint eine seltsame Auswahl zu sein.

Wenn ich manuell einen weiteren Eintrag zu diesem Filter hinzufügen (insgesamt 2), dann kopiert es es gut. Irgendwelche Ideen, warum dieser Code nicht funktioniert, wenn es nur einen Gegenstand gibt?

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

Rory Punkte helfend aus:

Wenn Sie Special nur auf eine Zelle anwenden, gilt er tatsächlich auf den gesamten verwendeten Bereich des Blattes.

Jetzt wissen wir, was das Problem ist, wir können es vermeiden! Die Codezeile, wo Sie SpecialCells verwenden:

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

Stattdessen zuerst den Bereich eingestellt, Test, wenn es nur eine Zelle enthält, dann gehen ...

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 

Hinweis, Sie vorausgesetzt, es ist sogar eine Reihe noch sichtbar. Es kann sein, dass die .End(xlUp) Zeile 1 auswählt, wenn keine sichtbaren Daten vorhanden sind. Sie können auch prüfen, welche Zeile das erste Mal ist!

---

Abgesehen: Sie sollten wirklich voll qualifizierenden Ihre Bereiche liegen, das heißt statt

Set r = Range("B2") 

Sie verwenden sollten

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

Dies wird Ihnen einige verwirrende Fehler in Zukunft zu retten. Es gibt Verknüpfungen, die Sie verwenden können, z. B. das Speichern von Wiederholungen mit With Blöcken oder das Deklarieren von Blattobjekten.

' 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

Danke

Specialcells 

@Rory Ist mit einer Zelle ausgewählt nicht. Angepasst indem Sie folgendermaßen vorgehen:

......

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