エクセルマクロ リストのデータを印刷するには？

質問

A　　　　　　　B　　　
1 　　1組　　　　金山君　　　　　　　　左のような表があり、これをA4用紙に横書きで
2　　　1組　　　　斎藤君
3　　　1組　　　　山口さん　　　　　　　　　　　　金山君　　　斎藤君　　　山口さん
4　　　1組　　　　三谷君　　　　　　　　　　　　　三谷君
5　　　2組　　　　野村さん
6　　　2組　　　　星野君　　　　　　　　　　　　　野村さん　　星野君
7　　　5組　　　　川上君
　　　　　　　　　　　　　　　　　　　　　　　　　　　　川上君

　　　　　　　　　　　　　　　　　　　　　　　のように、1行に各人数はあらかじめ決めておき、（この例では3　　　　　　　　　　　　　　　　　　　　　　　　名）、そして、「組」が変わるごとに1行あけてその行の先頭から書き始　　　　　　　　　　　　　　　　　　　　　　めるというマクロはどのように記述すればいいでしょうか。

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

回答No.1

WindFaller · ベストアンサー

こういう表をマクロで出すのが得意な人はいらっしゃると思います。
私は、あくまでも、長いブランクの練習用として書かせて頂きました。
本来は、ピボットテーブルなどで出せるような気がします。

>1行に各人数はあらかじめ決めておき、（この例では3名）
それはいいにしても、金山くんという文字が、なぜ、3行目から始まるのか分からないけれど、文章に内容からすると、左の表と、右側の書き出しとは、何も連動していないようですね。

'//
Sub Test1()
　Dim r As Range
　Dim r2 As Range
　Dim c As Range
　Dim objDic As Object
　Dim a As Variant
　Dim b As Variant
　Dim d As Variant
　Dim i As Long, j As Long, k As Long
　Dim x As Long, y As Long, cnt As Long
　Const ST As String = "D1" '書き出し位置(スタート=ST)
　Const KT As Long = 3 '一行の横の書き出しセル数（略称は桁=KT)

　'Dictionary オブジェクトを使う
　Set objDic = CreateObject("Scripting.Dictionary")
　Set r = Range("A1", Cells(Rows.Count, 1).End(xlUp))
　If r.Count < 2 Then Exit Sub 'データがない場合
　Application.ScreenUpdating = False
　For Each c In r
　　If c.Value <> "" Then
　　　If Not objDic.Exists(c.Value) Then
　　　　objDic.Add c.Value, c.Offset(, 1).Value
　　　Else
　　　　objDic.Item(c.Value) = objDic.Item(c.Value) & "," & c.Offset(, 1).Value
　　　End If
　　End If
　Next c
　a = objDic.Items
　b = objDic.Keys
　j = objDic.Count
　Set r2 = Range(ST)
　Do
　　d = Split(a(k), ",")
　　'書き出し
　　Do
　　　For x = 0 To KT - 1 '横に書き出しセル
　　　　r2.Offset(y, x).Value = d(cnt)
　　　　cnt = cnt + 1
　　　　If UBound(d) = cnt - 1 Then Exit Do
　　　Next x
　　　y = y + 1
　　Loop
　　If UBound(a) = k Then Exit Do
　　k = k + 1
　　y = y + 2
　　cnt = 0
　Loop
　Application.ScreenUpdating = True
　Set objDic = Nothing
　Set r = Nothing
End Sub
'//

お礼

ありがとうございました。