フィルタで絞り込んだ結果を、1セルずつ別シートのセルへコピーしたい

前提・実現したいこと

フィルタで絞り込んだ結果を、1セルずつ別シートのセルへコピーしたい。

[動作概要]
Sheet1：B2(部位)を入力し、マクロを実行することで10個目までのデータはD13~D22に、11個目以降のデータはE8～にコピーする。
Sheet2：部位を始め様々なデータが表に纏まっている。今回はそのうち1種のデータを抜き取る。

発生している問題・エラーメッセージ

フィルタの絞り込みを無視したセルをコピーしてしまう。

試したこと

絞り込み、データ任意の箇所にコピーすることは出来ましたが、絞り込みの結果に関わらずO4～をコピーしてしまいます。
コピー&貼り付けの方式を変えればうまく出来ないかなぁとは思うのですが...

VBA
1    Dim Part As String '部位
2    Dim CellNo As Long 'セルNo.
3    Dim Index As Long '最大行数
4    Dim i As Integer
5
6    With Sheets("Sheet1")
7    .Activate
8
9    CellNo = 1
10    Part = .Range("B2")
11
12    Sheets("Sheet2").Activate
13
14    '部位で絞り込み
15    If Not Part = "" Then
16        Index = ActiveSheet.UsedRange.Rows.Count
17        Range("$A$3:$BD$" & Index).AutoFilter Field:=8, Criteria1:=Part
18    End If
19
20    'コピー&貼り付け
21    Index = Range(Range("B4"), Cells(Rows.Count, 2).End(xlUp)).SpecialCells(xlCellTypeVisible).Count
22    For i = 1 To Index
23        If CellNo < 11 Then
24            .Range("D" & CellNo + 12) = Range("O" & CellNo + 3)
25        Else
26            .Range("E" & CellNo - 7) = Range("O" & CellNo + 3)
27        End If
28        CellNo = CellNo + 1
29    Next
30
31    End With

補足情報（FW/ツールのバージョンなど）

OS：windows 10
ツール：Microsoft Excel 2010

可能な限り自力で調べましたが、今回の解決策となる情報を見つけることが出来ませんでした。
何卒、宜しくお願い致します。

行動規範の内容に同意します

回答1件

ベストアンサー

SpecialCells(xlCellTypeVisible)でオートフィルター後、表示されているセルを取得できるのですから、それをコピー対象にすればいいでしょう。

下記のような感じです。

vba
1        '部位で絞り込み
2        If Not Part = "" Then
3            Index = ActiveSheet.UsedRange.Rows.Count
4            Range("$A$3:$BD$" & Index).AutoFilter Field:=8, Criteria1:=Part
5        End If
6        
7        Dim rng As Range
8        Set rng = Range("$O$3:$O" & Index).SpecialCells(xlCellTypeVisible) 'O列の表示セルを取得
9
10        'コピー&貼り付け
11        Dim c As Range
12        For Each c  in rng.Cells
13            If i < 11 Then
14                .Range("D" & i + 12) = c
15            Else
16                .Range("E" & i - 7) = c
17            End If
18        Next