エクセルＶＢＡ：繰り返し処理について

エクセルＶＢＡ初心者です。どうかご指導お願いします。
シート１に入力されたデータベースがあります。
B列には氏名が入力されています。
B2の値で絞りこんで、シート２に貼り付け、
B3の値で絞りこんで、シート３に貼り付け、
B4の値で絞り込んでシート４に貼り付けてB列の値が""（空白）になるまで繰り返すコードの書き方を教えてください。
さらに、B列には、当然同じ氏名が何回も入力されているので、前に一度出た人はパスするというようにしたいのです。

下記コードは、「B2の値で絞りこんで、シート２に貼り付け」だけをしたものですが、このコードを応用して作りたいのです。ご指導お願いします。


Sub test01()
　With sheets("sheet1"）Range("A1")
　　.AutoFilter field:=2, Criteria1:=Range("B2")
　　.CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A1")
　　.AutoFilter
　End With
End Sub

No.2 回答者： masa_019 回答日時： 2007/02/04 16:05

こんにちは。

こんな感じでどうでしょう？

Option Explicit

Sub test01(ByVal my_key As String, ByVal sh As Worksheet)
With Sheets("sheet1").Range("A1")
.AutoFilter field:=2, Criteria1:=my_key
.CurrentRegion.Copy Destination:=sh.Range("A1")
.AutoFilter
End With
End Sub

Private Function Func01(ByVal myRng As Range)
Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")
Dim r As Range
Dim mykey As String

For Each r In myRng
mykey = r.Value
If Not myDic.Exists(mykey) Then
myDic.Add mykey, mykey
End If
Next
Func01 = myDic.Keys
End Function


Sub Macro02()
Dim rng As Range
Dim i As Long
Dim mykeys
Dim mysh As Worksheet

Application.ScreenUpdating = False
Set rng = Sheets("Sheet1").Range("A1"). _
CurrentRegion.Columns(2).Cells
mykeys = Func01(rng)

For i = 1 To UBound(mykeys)
　On Error GoTo ErrorHandler
　Set mysh = ThisWorkbook.Sheets("Sheet" & i + 1)
　On Error GoTo 0
　test01 mykeys(i), mysh
Next

Set mysh = Nothing
Set rng = Nothing
Application.ScreenUpdating = True
Exit Sub

ErrorHandler:
Set mysh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
mysh.Name = "Sheet" & i + 1
Resume Next

End Sub

この回答へのお礼

ご回答ありがとうございました。
完璧な結果がでました。
コード内容に理解がともなわず、ただただ驚くばかりです。
心より感謝申し上げます。
内容を理解できるように勉強してみます。

お礼日時：2007/02/04 19:18

No.1 ベストアンサー 回答者： ham_kamo 回答日時： 2007/02/04 15:50

質問文のマクロを元に、重複チェックをしながらForループでまわしてオートフィルタでの絞り込み、シートの追加、コピーを行ってみました。

シート名はとりあえず氏名にしています。

Sub test02()
　Dim i As Integer, j As Integer
　Dim IsNewName As Boolean
　With Sheets("sheet1")
　　For i = 2 To Range("B65536").End(xlUp).Row
　　　IsNewName = True
　　　For j = 2 To Worksheets.Count
　　　　If Worksheets(j).Name = .Range("B" & i).Value Then
　　　　　IsNewName = False
　　　　　Exit For
　　　　End If
　　　Next
　　　If IsNewName = True Then
　　　　.Range("A1").AutoFilter field:=2, Criteria1:=.Range("B" & i).Value
　　　　Worksheets.Add After:=Worksheets(Worksheets.Count)
　　　　Worksheets(Worksheets.Count).Name = .Range("B" & i).Value
　　　　.Range("A1").CurrentRegion.Copy Destination:=Worksheets(Worksheets.Count).Range("A1")
　　　End If
　　Next
　　.Range("A1").AutoFilter
　End With
End Sub

この回答へのお礼

ご回答ありがとうございました。
質問内容をカバーして有り余るほどの完璧なコードをありがとうございました。心より感謝申し上げます^^

お礼日時：2007/02/04 19:14