VBAノック30本目：名札作成（段組み） - 和風スパゲティのレシピ

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：名札作成（段組み）
ソースコード
- 定義モジュール
- メインモジュール
解説

出題：名札作成（段組み）

#VBA100本ノック 30本目
古臭いですが名札を作ることになりました。
「名簿」シートのB列に役職、C列に名前が入っています。
「名簿」から「名札」を作成してください。
「名札」はレイアウト・書式を作成済みですが、行数は毎回変わるので3行目以降は1,2行目からコピーしてください。
※画像参照

名札サンプル

◇ 出題ページはこちら

ソースコード

定義モジュール

Option Explicit

' 名簿
Public Const R1st名簿 = 2
Public Const C1st名簿 = 1
Public Enum CNo名簿
    No = C1st名簿
    役職
    氏名
End Enum
Public Const CLast名簿 = CNo名簿.氏名

' 名札
Public Const RCount名札各ブロック = 2
Public Const CCount名札各ブロック = 1
Public Const Countブロック列数 = 2

メインモジュール

Option Explicit

' 100本ノック030：名札作成（段組み）
Sub 名簿を名札シートへ出力する()
    
    ' 第1ブロックを残してすべて削除
    Call 指定行より下をすべて削除する(WS名札, RCount名札各ブロック + 1)
    
    ' 第1ブロックの値を消去
    Intersect(WS名札.UsedRange, WS名札.Rows(1)) _
        .Resize(RCount名札各ブロック).Value = ""
    
    ' 必要ブロック数分コピー
    Dim RLast名簿 As Long: RLast名簿 = Get最終行(WS名簿)
    Dim データ数 As Long: データ数 = RLast名簿 - R1st名簿 + 1
    Dim ブロック行数 As Long
    ブロック行数 = (データ数 + 1) \ Countブロック列数
    If ブロック行数 >= 2 Then
        WS名札.Rows(1).Resize(RCount名札各ブロック).Copy _
            WS名札.Rows(RCount名札各ブロック + 1) _
                .Resize((ブロック行数 - 1) * RCount名札各ブロック)
    End If
    
    ' 名簿データをループ
    Dim R_名札 As Long: R_名札 = 1
    Dim C_名札 As Long: C_名札 = 1
    Dim 現在の列ブロック数 As Long: 現在の列ブロック数 = 1
    Dim R As Long
    For R = R1st名簿 To RLast名簿
        
        ' 現在の行を名札に印字
        WS名札.Cells(R_名札, C_名札) = WS名簿.Cells(R, CNo名簿.役職)
        WS名札.Cells(R_名札 + 1, C_名札) = WS名簿.Cells(R, CNo名簿.氏名)
        
        ' 印字アドレスを更新
        If 現在の列ブロック数 < Countブロック列数 Then
            現在の列ブロック数 = 現在の列ブロック数 + 1
            C_名札 = C_名札 + CCount名札各ブロック
        Else
            現在の列ブロック数 = 1
            R_名札 = R_名札 + RCount名札各ブロック
            C_名札 = 1
        End If
        
    Next
    
End Sub

解説

データをブロックごとに印字していく問題です。

シート上のカレンダーに印字するときなどにもよく出てくる処理ですね。

ロジックとしては「Mod演算で出力先を計算する」方法と、
今回のように「出力先を加算していき、右端についたら折り返す」方法があります。

どちらでも好きな方で実装してください。

今回の処理は以下のように数字のベタ打ちでももちろん動きます。

Sub 名簿を名札シートへ出力する()
    
    ' 第1ブロックを残してすべて削除
    Call 指定行より下をすべて削除する(WS名札, 3)
    
    ' 第1ブロックの値を消去
    Intersect(WS名札.UsedRange, WS名札.Rows(1)) _
        .Resize(2).Value = ""
    
    ' 必要ブロック数分コピー
    Dim RLast名簿 As Long: RLast名簿 = Get最終行(WS名簿)
    Dim データ数 As Long: データ数 = RLast名簿 - R1st名簿 + 1
    Dim ブロック行数 As Long
    ブロック行数 = (データ数 + 1) \ 2
    If ブロック行数 >= 2 Then
        WS名札.Rows(1).Resize(2).Copy _
            WS名札.Rows(3).Resize((ブロック行数 - 1) * 2)
    End If
    
    ' 名簿データをループ
    Dim R_名札 As Long: R_名札 = 1
    Dim C_名札 As Long: C_名札 = 1
    Dim R As Long
    For R = R1st名簿 To RLast名簿
        
        ' 現在の行を名札に印字
        WS名札.Cells(R_名札, C_名札) = WS名簿.Cells(R, CNo名簿.役職)
        WS名札.Cells(R_名札 + 1, C_名札) = WS名簿.Cells(R, CNo名簿.氏名)
        
        ' 印字アドレスを更新
        If C_名札 = 1 Then
            C_名札 = C_名札 + 1
        Else
            R_名札 = R_名札 + 2
            C_名札 = 1
        End If
        
    Next
    
End Sub