EXCEL2010VBAでシートに抽出データをアウトプットしたい

EXCEL2010VBAで作成したデータ（添付の左表）から自動的に別ブックの別シートへ、個人のデータをアウトプットしたいです。

左表の一覧から一人を別ブックの１つのシートに一人ずつアウトプットしたいと思っています。

マクロを使うことになると思いますが、どなたか方法を教えて頂けませんでしょうか？

よろしくお願いします。

No.2 回答者： WindFaller 回答日時： 2016/05/24 17:47

VBカテゴリで気が付きましたので、訂正したものを出しておきます。

ただし、まだまだ、改良の余地があります。
ご自身で研究されて、より良いものを目指してもよいかと思います。

'//
Sub Categorizing_Sample()
　　Dim objDic As Object 'New Scripting.Dictionary
　　Dim i As Long, m As Long, j As Long, k As Long
　　Dim LastRow As Long
　　Dim dat
　　Dim ar
　　Dim Wkb As Workbook
　　Dim fn As String
　　Dim myPath As String
　　Dim strErr As String
　　
　　myPath = Application.DefaultFilePath
　　If Right(myPath, 1) <> "\" Then myPath = myPath & "\"
　　'*******************
　　'ユーザー設定
　　'もしデフォルトのフォルダーを使わないなら、上記のもmyPath..+If Right..
　　'の２行を削除して、この下の行に、myPath =(フルアドレスのフォルダーを書いてください
　　myPath = myPath & "Test1\"
　　
　　'*******************
　　LastRow = Cells(Rows.Count, "B").End(xlUp).Row '最後の行を探す
　　dat = Range("B5:D" & LastRow).Value '配列に置き換え
　　'****************************
　　Set objDic = CreateObject("Scripting.Dictionary")
　　
　　For j = 1 To UBound(dat, 2) - 1
　　　　For i = 1 To UBound(dat)
　　　　　　If dat(i, j) <> "" Then
　　　　　　　　If objDic.Exists(dat(i, j)) Then
　　　　　　　　　　objDic.Item(dat(i, j)) = _
　　　　　　　　　　objDic.Item(dat(i, j)) & "," & dat(i, UBound(dat, 2))
　　　　　　　　Else
　　　　　　　　　　objDic.Add dat(i, j), dat(i, UBound(dat, 2))
　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　Next j
　　m = 0
　　
　　For i = 0 To objDic.Count - 1
　　　　fn = objDic.Keys()(i) '名前
　　　　If Dir(myPath & fn & ".xlsx") <> "" Then
　　　　　　Set Wkb = Workbooks.Open(myPath & fn & ".xlsx")
　　　　　　With Wkb.Worksheets(1)　　'シート1
　　　　　　　　.Cells(1, 1).Value = objDic.Keys()(i)
　　　　　　　　ar = Split(objDic.Item(objDic.Keys()(i)), ",")
　　　　　　　　k = UBound(ar)
　　　　　　　　.Cells(2, 1).Resize(k + 1).Value = Application.Transpose(ar)
　　　　　　　　m = m + 1
　　　　　　End With
　　　　　　Wkb.Close True
　　　　Else
　　　　　　strErr = strErr & " " & fn
　　　　End If
　　Next i
　　If Len(strErr) > 2 Then
　　　　MsgBox "Err: " & strErr
　　End If
End Sub

http://bit.ly/1VguE61
psw:このURLの/qa/以降の数字のみ
有効期間は、2016/05/24 17:30:08 - 5/31 同時間まで
場合によっては中途で削除することもあります。

No.1 回答者： WindFaller 回答日時： 2016/05/24 09:42

私は、このご質問に興味を持ちましたが、以下のような簡単なマクロであっても、VBAマクロを多少知らないと扱いのには難しいのではないか、と思います。

言い換えると、他人の考えや思惑で作られたものは、一旦、自分の中で解釈しないと、よくわからないということです。

今回は、やむを得ず、Dictionary オブジェクトを利用しました。

>自動的に別ブックの別シートへ、個人のデータをアウトプットしたいです。
リストを作るのか、それとも、氏名で開くのか、この決定は、ご自身で決めてください。

名前と同じファイル名が存在すれば、それを開けて書き込むようにされています。
青木でしたら、"青木.xlsx" のファイルを探して開けて、コピーします。
もし、なければ、エラーとして記帳され、後で、メッセージが出てきます。

それから、
>左表の一覧から一人を別ブックの１つのシートに一人ずつアウトプットしたいと思っています。

一回きりですまない場合は、どうするのか、とか先のことを考慮しなければならないかもしれません。
なお、ブックを予め作るマクロも考えあります。

※絶対パスというのは、C:\Users\[User]\My Documents\Stock
というように、ルートから全部を書くことです。

'//
Sub Categorizing_Sample()
　　Dim objDic As Object 'New Scripting.Dictionary
　　Dim i As Long, m As Long, j As Long, k As Long
　　Dim LastRow As Long
　　Dim ar
　　Dim Wkb As Workbook
　　Dim fn As String
　　Dim myPath As String
　　Dim strErr As String
　　
　　myPath = Application.DefaultFilePath
　　If Right(myPath, 1) <> "\" Then myPath = myPath & "\"
　　'*******************
　　'ユーザー設定
　　'もしデフォルトのフォルダーを使わないなら、上記のもmyPath..+If Right..
　　'の２行を削除して、この下の行に、myPath =(絶対パスを書いてください。C:\.....
　　myPath = myPath & "Test1\"
　　'*******************
　　Set objDic = CreateObject("Scripting.Dictionary")
　　
　　LastRow = Cells(Rows.Count, 1).End(xlUp).Row
　　For j = 1 To 2
　　　　For i = 5 To LastRow
　　　　　　If Cells(i, j).Value <> "" Then
　　　　　　　　If objDic.Exists(Cells(i, j).Value) Then
　　　　　　　　　　objDic.Item(Cells(i, j).Value) = _
　　　　　　　　　　objDic.Item(Cells(i, j).Value) & "," & Cells(i, 3).Value
　　　　　　　　Else
　　　　　　　　　　objDic.Add Cells(i, j).Value, Cells(i, 3).Value
　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　Next j
　　m = 0
　　
　　For i = 0 To objDic.Count - 1
　　　　fn = objDic.Keys()(i) '名前
　　　　If Dir(myPath & fn & ".xlsx") <> "" Then
　　　　　　Set Wkb = Workbooks.Open(myPath & fn & ".xlsx")
　　　　　　With Wkb.Worksheets(1)　　'シート1
　　　　　　　　.Cells(1, 1).Value = objDic.Keys()(i)
　　　　　　　　ar = Split(objDic.Item(objDic.Keys()(i)), ",")
　　　　　　　　k = UBound(ar)
　　　　　　　　.Cells(2, 1).Resize(k + 1).Value = Application.Transpose(ar)
　　　　　　　　m = m + 1
　　　　　　End With
　　　　　　Wkb.Close True
　　　　Else
　　　　　　strErr = strErr & " " & fn
　　　　End If
　　Next i
　　If Len(strErr) > 2 Then
　　　　MsgBox "Err: " & strErr
　　End If
End Sub

'//