エクセルで出勤簿とスケジュール

質問

会社の出勤記録を作成しています。
土木関係の仕事で、現場の作業員が毎日、１～１０班として作業するにあたり、班ごとにスケジュール（メンバー表）を作成しているのですが

山田 １ 鈴木 ２　島田 １　宮下 １ 大木 ２

上記のように出勤簿の名前のとなりのセルに班の番号を入力していって、
下記のように班ごとに表にまとまるよう反映されるように作成したいのですが、なにかいい方法はありますでしょうか。

１班　　山田　島田　宮下
２班　　鈴木　大木　・・・・・・

よろしくお願い致します。

回答No.2

merlionXX

関数では考えるだけでかなり面倒くさいですね。
もし表の配置がA1から始まり、A1が氏名でB1が班、と交互に連続した横に並んだ一行のデータなら、以下の手順をおためしください。

1.AltキーとF11キー同時に押し（以下Alt+F11キーと記述）て Visual Basic Editor を呼び出します。

2.Visual Basic Editor のメニューから「挿入」、「標準モジュール」で出てきたコードウィンド（右側の白い広い部分）に以下のコード（Sub～End Sub）をコピペします。

'********これより下**********

Sub test01()
Dim x As Long, i As Long
Dim myDic As Object
Dim ns As Worksheet
With ActiveSheet
Set myRng = .Range(.Range("A1"), .Range("A1").End(xlToRight))
x = myRng.Count
If x Mod 2 <> 0 Then
MsgBox "班/氏名がセットになっていません。"
Exit Sub
End If
Set myDic = CreateObject("Scripting.Dictionary")
For i = 2 To x Step 2
If Not myDic.Exists(.Cells(1, i).Value) Then
myDic.Add Key:=.Cells(1, i).Value, Item:=.Cells(1, i - 1).Value
Else
myDic(.Cells(1, i).Value) = myDic(.Cells(1, i).Value) & "＾" & .Cells(1, i - 1).Value
End If
Next i
End With
Set ns = Worksheets.Add(After:=ActiveSheet)
With ns
.Cells(1, 1).Resize(myDic.Count).Value = Application.Transpose(myDic.Keys) '
.Cells(1, 2).Resize(myDic.Count).Value = Application.Transpose(myDic.Items)
.Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, Other:=True, OtherChar:="＾" '
End With
End Sub

'********これより上**********

3.Alt+F11キーでデータのあるワークシートへもどります.

4. Alt+F8キーで出てきたマクロ名（test01）を選択して実行します。
これで、新しいシートが挿入されて、そこにご要望のように表示されるはずです。

回答No.1

noname#192382

もとの表を下の左のように作っておけば、マクロを使えば下右のような結果が得られますが・・・

山田 1 1 山田
鈴木 2 1 島田
島田 1 1 宮下
宮下 1 2 鈴木
大木 2 2 大木
Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2009/5/23 ユーザー名 :
'

'
Range("A1:B20").Select
Selection.Copy
Range("D1").Select
ActiveSheet.Paste
Columns("D:E").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Columns("D:D").Select
Selection.Cut
Columns("F:F").Select
ActiveSheet.Paste
Range("E7").Select
End Sub