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転記定義を3つに分割した配列(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