Option Explicit
 
Public Sub シート振り分け()
    Dim ms As Worksheet 'マスターシート
    Dim ws As Worksheet '名前シート
    Dim dicT As Object  '名前のdictionary キー：名前 値：行番号（|で区切る）
    Dim row_m As Long   '行番号（マスター）
    Dim maxrow As Long  '最大行番号（マスター）
    Dim key As Variant  'キー（名前）
    Dim rows As Variant '行番号の配列
    Dim col_arr As Variant  '転記列定義（配列）
    Dim cole As Variant     '1転記定義
    Dim elms As Variant     '1転記定義を３つに分割した配列(0:転記元列、1:転記先列、2:行の補正値)
    Dim col0 As String      '転記元列
    Dim col1 As String      '転記先列
    Dim bias As Long        '行の補正値
    Dim row_w As Long       '転記先行番号
    Dim i As Long
    col_arr = Array("B|A|0", "C|F|0", "D|G|1", "E|H|0")
    Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set ms = Worksheets("貼り付けシート")
    maxrow = ms.Cells(ms.rows.Count, "A").End(xlUp).Row
    '名前と行番号を記憶する
    For row_m = 2 To maxrow
        key = ms.Cells(row_m, "A").Value
        If dicT.exists(key) = False Then
            dicT(key) = CStr(row_m)
        Else
            dicT(key) = dicT(key) & "|" & CStr(row_m)
        End If
    Next
    '名前毎に処理を繰り返す
    For Each key In dicT.keys
        '名前のシートを検索し、wsオブジェクトを設定する
        Call find_sheet(key, ws)
        'ワークシート事前設定処理
        Call set_ws_before(ws)
        '転記列分の繰り返し
        For Each cole In col_arr
            elms = Split(cole, "|")
            col0 = elms(0)          '転記元
            col1 = elms(1)          '転記先
            bias = CLng(elms(2))    '補正値
            '転記行分の繰り返し
            rows = Split(dicT(key), "|")
            For i = 0 To UBound(rows)
                row_m = CLng(rows(i))       '文字を数値に変換
                row_w = i * 3 + 3 + bias    '転記先の行を算出
                ws.Cells(row_w, col1).Value = ms.Cells(row_m, col0).Value   'データ転記
            Next
        Next
        'ワークシート事後設定処理
        Call set_ws_after(ws)
    Next
    MsgBox ("完了")
End Sub
'シート検索＆オブジェクト設定
Private Sub find_sheet(ByVal sheet_name As String, ws As Worksheet)
    Dim i As Long
    '指定されたシート名が存在するかチェックする
    For i = 1 To Worksheets.Count
        If LCase(Worksheets(i).name) = LCase(sheet_name) Then
            '存在した場合、wsオブジェクトを設定する
            Set ws = Worksheets(i)
            Exit Sub
        End If
    Next
    '存在しない場合、最後に追加する
    Set ws = Worksheets.Add(, Worksheets(Worksheets.Count))
    ws.name = sheet_name
End Sub
'事前設定処理
Private Sub set_ws_before(ws As Worksheet)
    'ワークシートクリア
    ws.Cells.ClearContents
    'これはサンプルです。必要であれば修正してください
'    ws.Range("A1:J2").Merge
'    ws.Range("A1").Value = "食べ物依頼"
'    ws.Cells.Font.name = "Meiryo UI"
'    ws.Range("A1").Font.Size = 20
'    ws.Range("A1").Font.Bold = True
'    ws.Range("A1").Cells.HorizontalAlignment = xlCenter
End Sub
'事後前設定処理
Private Sub set_ws_after(ws As Worksheet)
    '必要であれば、ここに処理を記入
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOOCt+ODvOODiOaMr+OCiuWIhuOBkSgpCiAgICBEaW0gbXMgQXMgV29ya3NoZWV0ICfjg57jgrnjgr/jg7zjgrfjg7zjg4gKICAgIERpbSB3cyBBcyBXb3Jrc2hlZXQgJ+WQjeWJjeOCt+ODvOODiAogICAgRGltIGRpY1QgQXMgT2JqZWN0ICAn5ZCN5YmN44GuZGljdGlvbmFyeSDjgq3jg7zvvJrlkI3liY0g5YCk77ya6KGM55Wq5Y+377yIfOOBp+WMuuWIh+OCi++8iQogICAgRGltIHJvd19tIEFzIExvbmcgICAn6KGM55Wq5Y+377yI44Oe44K544K/44O877yJCiAgICBEaW0gbWF4cm93IEFzIExvbmcgICfmnIDlpKfooYznlarlj7fvvIjjg57jgrnjgr/jg7zvvIkKICAgIERpbSBrZXkgQXMgVmFyaWFudCAgJ+OCreODvO+8iOWQjeWJje+8iQogICAgRGltIHJvd3MgQXMgVmFyaWFudCAn6KGM55Wq5Y+344Gu6YWN5YiXCiAgICBEaW0gY29sX2FyciBBcyBWYXJpYW50ICAn6Lui6KiY5YiX5a6a576p77yI6YWN5YiX77yJCiAgICBEaW0gY29sZSBBcyBWYXJpYW50ICAgICAnMei7ouiomOWumue+qQogICAgRGltIGVsbXMgQXMgVmFyaWFudCAgICAgJzHou6LoqJjlrprnvqnjgpLvvJPjgaTjgavliIblibLjgZfjgZ/phY3liJcoMDrou6LoqJjlhYPliJfjgIExOui7ouiomOWFiOWIl+OAgTI66KGM44Gu6KOc5q2j5YCkKQogICAgRGltIGNvbDAgQXMgU3RyaW5nICAgICAgJ+i7ouiomOWFg+WIlwogICAgRGltIGNvbDEgQXMgU3RyaW5nICAgICAgJ+i7ouiomOWFiOWIlwogICAgRGltIGJpYXMgQXMgTG9uZyAgICAgICAgJ+ihjOOBruijnOato+WApAogICAgRGltIHJvd193IEFzIExvbmcgICAgICAgJ+i7ouiomOWFiOihjOeVquWPtwogICAgRGltIGkgQXMgTG9uZwogICAgY29sX2FyciA9IEFycmF5KCJCfEF8MCIsICJDfEZ8MCIsICJEfEd8MSIsICJFfEh8MCIpCiAgICBTZXQgZGljVCA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkRpY3Rpb25hcnkiKSAnIOmAo+aDs+mFjeWIl+OBruWumue+qQogICAgU2V0IG1zID0gV29ya3NoZWV0cygi6LK844KK5LuY44GR44K344O844OIIikKICAgIG1heHJvdyA9IG1zLkNlbGxzKG1zLnJvd3MuQ291bnQsICJBIikuRW5kKHhsVXApLlJvdwogICAgJ+WQjeWJjeOBqOihjOeVquWPt+OCkuiomOaGtuOBmeOCiwogICAgRm9yIHJvd19tID0gMiBUbyBtYXhyb3cKICAgICAgICBrZXkgPSBtcy5DZWxscyhyb3dfbSwgIkEiKS5WYWx1ZQogICAgICAgIElmIGRpY1QuZXhpc3RzKGtleSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgIGRpY1Qoa2V5KSA9IENTdHIocm93X20pCiAgICAgICAgRWxzZQogICAgICAgICAgICBkaWNUKGtleSkgPSBkaWNUKGtleSkgJiAifCIgJiBDU3RyKHJvd19tKQogICAgICAgIEVuZCBJZgogICAgTmV4dAogICAgJ+WQjeWJjeavjuOBq+WHpueQhuOCkue5sOOCiui/lOOBmQogICAgRm9yIEVhY2gga2V5IEluIGRpY1Qua2V5cwogICAgICAgICflkI3liY3jga7jgrfjg7zjg4jjgpLmpJzntKLjgZfjgIF3c+OCquODluOCuOOCp+OCr+ODiOOCkuioreWumuOBmeOCiwogICAgICAgIENhbGwgZmluZF9zaGVldChrZXksIHdzKQogICAgICAgICfjg6/jg7zjgq/jgrfjg7zjg4jkuovliY3oqK3lrprlh6bnkIYKICAgICAgICBDYWxsIHNldF93c19iZWZvcmUod3MpCiAgICAgICAgJ+i7ouiomOWIl+WIhuOBrue5sOOCiui/lOOBlwogICAgICAgIEZvciBFYWNoIGNvbGUgSW4gY29sX2FycgogICAgICAgICAgICBlbG1zID0gU3BsaXQoY29sZSwgInwiKQogICAgICAgICAgICBjb2wwID0gZWxtcygwKSAgICAgICAgICAn6Lui6KiY5YWDCiAgICAgICAgICAgIGNvbDEgPSBlbG1zKDEpICAgICAgICAgICfou6LoqJjlhYgKICAgICAgICAgICAgYmlhcyA9IENMbmcoZWxtcygyKSkgICAgJ+ijnOato+WApAogICAgICAgICAgICAn6Lui6KiY6KGM5YiG44Gu57mw44KK6L+U44GXCiAgICAgICAgICAgIHJvd3MgPSBTcGxpdChkaWNUKGtleSksICJ8IikKICAgICAgICAgICAgRm9yIGkgPSAwIFRvIFVCb3VuZChyb3dzKQogICAgICAgICAgICAgICAgcm93X20gPSBDTG5nKHJvd3MoaSkpICAgICAgICfmloflrZfjgpLmlbDlgKTjgavlpInmj5sKICAgICAgICAgICAgICAgIHJvd193ID0gaSAqIDMgKyAzICsgYmlhcyAgICAn6Lui6KiY5YWI44Gu6KGM44KS566X5Ye6CiAgICAgICAgICAgICAgICB3cy5DZWxscyhyb3dfdywgY29sMSkuVmFsdWUgPSBtcy5DZWxscyhyb3dfbSwgY29sMCkuVmFsdWUgICAn44OH44O844K/6Lui6KiYCiAgICAgICAgICAgIE5leHQKICAgICAgICBOZXh0CiAgICAgICAgJ+ODr+ODvOOCr+OCt+ODvOODiOS6i+W+jOioreWumuWHpueQhgogICAgICAgIENhbGwgc2V0X3dzX2FmdGVyKHdzKQogICAgTmV4dAogICAgTXNnQm94ICgi5a6M5LqGIikKRW5kIFN1Ygon44K344O844OI5qSc57Si77yG44Kq44OW44K444Kn44Kv44OI6Kit5a6aClByaXZhdGUgU3ViIGZpbmRfc2hlZXQoQnlWYWwgc2hlZXRfbmFtZSBBcyBTdHJpbmcsIHdzIEFzIFdvcmtzaGVldCkKICAgIERpbSBpIEFzIExvbmcKICAgICfmjIflrprjgZXjgozjgZ/jgrfjg7zjg4jlkI3jgYzlrZjlnKjjgZnjgovjgYvjg4Hjgqfjg4Pjgq/jgZnjgosKICAgIEZvciBpID0gMSBUbyBXb3Jrc2hlZXRzLkNvdW50CiAgICAgICAgSWYgTENhc2UoV29ya3NoZWV0cyhpKS5uYW1lKSA9IExDYXNlKHNoZWV0X25hbWUpIFRoZW4KICAgICAgICAgICAgJ+WtmOWcqOOBl+OBn+WgtOWQiOOAgXdz44Kq44OW44K444Kn44Kv44OI44KS6Kit5a6a44GZ44KLCiAgICAgICAgICAgIFNldCB3cyA9IFdvcmtzaGVldHMoaSkKICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICBFbmQgSWYKICAgIE5leHQKICAgICflrZjlnKjjgZfjgarjgYTloLTlkIjjgIHmnIDlvozjgavov73liqDjgZnjgosKICAgIFNldCB3cyA9IFdvcmtzaGVldHMuQWRkKCwgV29ya3NoZWV0cyhXb3Jrc2hlZXRzLkNvdW50KSkKICAgIHdzLm5hbWUgPSBzaGVldF9uYW1lCkVuZCBTdWIKJ+S6i+WJjeioreWumuWHpueQhgpQcml2YXRlIFN1YiBzZXRfd3NfYmVmb3JlKHdzIEFzIFdvcmtzaGVldCkKICAgICfjg6/jg7zjgq/jgrfjg7zjg4jjgq/jg6rjgqIKICAgIHdzLkNlbGxzLkNsZWFyQ29udGVudHMKICAgICfjgZPjgozjga/jgrXjg7Pjg5fjg6vjgafjgZnjgILlv4XopoHjgafjgYLjgozjgbDkv67mraPjgZfjgabjgY/jgaDjgZXjgYQKJyAgICB3cy5SYW5nZSgiQTE6SjIiKS5NZXJnZQonICAgIHdzLlJhbmdlKCJBMSIpLlZhbHVlID0gIumjn+OBueeJqeS+nemgvCIKJyAgICB3cy5DZWxscy5Gb250Lm5hbWUgPSAiTWVpcnlvIFVJIgonICAgIHdzLlJhbmdlKCJBMSIpLkZvbnQuU2l6ZSA9IDIwCicgICAgd3MuUmFuZ2UoIkExIikuRm9udC5Cb2xkID0gVHJ1ZQonICAgIHdzLlJhbmdlKCJBMSIpLkNlbGxzLkhvcml6b250YWxBbGlnbm1lbnQgPSB4bENlbnRlcgpFbmQgU3ViCifkuovlvozliY3oqK3lrprlh6bnkIYKUHJpdmF0ZSBTdWIgc2V0X3dzX2FmdGVyKHdzIEFzIFdvcmtzaGVldCkKICAgICflv4XopoHjgafjgYLjgozjgbDjgIHjgZPjgZPjgavlh6bnkIbjgpLoqJjlhaUKRW5kIFN1Ygo=