VBA オートフィルタで抽出したものを連続貼り付け

質問

下記のように情報が１００近くまで存在した場合に、オートフィルターで一つずつ抽出したものをコピーし、新規シートに貼り付けたいのですが、どうすれば良いのでしょうか？

１
１
１
２
２
２
３
３
３

たとえばシート１に
１
１
１
　　　　シート２に
２
2
2
といったように処理したいので、教えて下さい。

ｖｂａの参考書とサンプルを見て下記のように作成したのですが上手くいきません。
どんな本を読めば作成出来るようになるのかわからず、質問させていただきました。

ub オートフィルター()

Dim myRng As Range
Dim mySht As Worksheet
Set myRng = _
Worksheets(1).Range("A1").CurrentRegion

With Worksheets

Set mySht = .Add(after:=.Item(.Count))

End With

With myRng

.AutoFilter field:=1, Criteria1:=8

On Error Resume Next

.Resize(.Rows.Count - 1).Offset(1).Copy mySht.Range("A1")

.SpecialCells(xlCellTypeVisible).Copy mySht.Range("A1").AutoFilter

mySht.Range("A1").AutoFilter

If Err.Number <> 0 Then

Application.DisplayAlerts = False

mySht.Delete

Application.DisplayAlerts = True

End If

On Error GoTo 0

End With

Set myRng = Nothing

Set mySht = Nothing

End Sub

回答No.3

merlionXX

ANo2 merlionXXです。
見出し行がある場合のほうの記述に抜けがありました。
修正します。

Sub test01() '見出し行がある場合
　　Dim ws(1) As Worksheet
　　Dim myW
　　Dim i As Long
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set ws(0) = ActiveSheet
　　Set myRng = ws(0).Range("A1").CurrentRegion
　　myW = myRng.Columns(1).Value
　　For i = 1 To UBound(myW)
　　　　If Not myDic.Exists(myW(i, 1)) Then
　　　　　　myDic.Add myW(i, 1), ""
　　　　End If
　　Next i
　　With ws(0)
　　　　For i = 2 To myDic.Count
　　　　　　.AutoFilterMode = False
　　　　　　myRng.Rows(1).AutoFilter
　　　　　　myRng.AutoFilter Field:=1, Criteria1:=myDic.keys()(i - 1)
　　　　　　Set ws(1) = Sheets.Add(after:=Sheets(Sheets.Count))
　　　　　　myRng.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy ws(1).Range("A1")
　　　　Next i
　　End With
End Sub

回答No.2

merlionXX

ご質問に提示されたデータでは見出し行がないようですが、オートフィルターというからには1行目に見出し行がないのが不思議です。
（見出しなしでオートフィルターを設置すると、1行目は常に表示されますので）
単に省略しただけなのでしょうか？
一応、最初のデータに見出し行がある場合と、ない場合の二つの例を書きます。
別シートに転記の際は、ご提示のように見出し行はつけていません。
フィルタをかけるための重複なしのリストの作成には.Dictionaryオブジェクトを利用しました。
ご参考まで。

Sub test01() '見出し行がある場合
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set ws(0) = ActiveSheet
　　Dim i As Long
　　Set myRng = ws(0).Range("A1").CurrentRegion
　　myW = myRng.Columns(1).Value
　　For i = 1 To UBound(myW)
　　　　If Not myDic.Exists(myW(i, 1)) Then
　　　　　　myDic.Add myW(i, 1), ""
　　　　End If
　　Next i
　　With ws(0)
　　　　For i = 2 To myDic.Count
　　　　　　.AutoFilterMode = False
　　　　　　myRng.Rows(1).AutoFilter
　　　　　　myRng.AutoFilter Field:=1, Criteria1:=myDic.keys()(i - 1)
　　　　　　Set ws(1) = Sheets.Add(after:=Sheets(Sheets.Count))
　　　　　　myRng.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy ws(1).Range("A1")
　　　　Next i
　　End With
End Sub

Sub test02() '見出し行がない場合
　　Dim ws(1) As Worksheet
　　Dim myW
　　Dim myDic As Object
　　Dim i As Long
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set ws(0) = ActiveSheet
　　ws(0).Rows("1").Insert Shift:=xlDown
　　Set myRng = ws(0).Range("A1").CurrentRegion
　　myW = myRng.Columns(1).Value
　　For i = 2 To UBound(myW)
　　　　If Not myDic.Exists(myW(i, 1)) Then
　　　　　　myDic.Add myW(i, 1), ""
　　　　End If
　　Next i
　　With ws(0)
　　　　For i = 1 To myDic.Count
　　　　　　.AutoFilterMode = False
　　　　　　myRng.Rows(1).AutoFilter
　　　　　　myRng.AutoFilter Field:=1, Criteria1:=myDic.keys()(i - 1)
　　　　　　Set ws(1) = Sheets.Add(after:=Sheets(Sheets.Count))
　　　　　　myRng.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy ws(1).Range("A1")
　　　　Next i
　　End With
End Sub

回答No.1

xls88

フィルタリストを取得しリストをLoopしながらオートフィルタしてみます。

Dim mySht As Worksheet
Dim myRng As Range
Dim fnRng As Range
Dim c As Range
Dim myData() As String '---フィルタリスト
Dim fn As Long '---Field番号
Dim flg As Boolean
Dim i As Long

ReDim myData(0)
fn = 1
Set myRng = Worksheets(1).Range("A1").CurrentRegion
Set fnRng = myRng.Columns(fn).Resize(myRng.Rows.Count - 1).Offset(1)

'リスト
For Each c In Range(fnRng.Address)
If myData(0) = "" Then
myData(0) = c.value
Else
flg = False
For i = 0 To UBound(myData)
If myData(i) = c.value Then
flg = True
Exit For
End If
Next
If Not flg Then
ReDim Preserve myData(UBound(myData) + 1)
myData(UBound(myData)) = c.value
End If
End If
Next

'オートフィルタ
With myRng
For i = 0 To UBound(myData)
With Worksheets
Set mySht = .Add(after:=.Item(.Count))
End With
.AutoFilter Field:=fn, Criteria1:=myData(i)
.Resize(.Rows.Count - 1).Offset(1).Copy mySht.Range("A1")
Next
End With

≪参考≫
リストの取得は、下記掲示板でSALINGERさんのコードを使わせて頂きました。

特定のセル範囲を重複無しで配列に格納する
http://q.hatena.ne.jp/1249216965