速読練習ツール自動生成マクロをソースコードつきで公開しました。 – Excel マクロ・VBA

エクセルマクロ・VBA達人養成塾 小川です。

昨日のブログに書いた、「フォーカス・リーディング」の寺田昌嗣さんから依頼されて作ったマクロ。公開します。

以下からダウンロードしてください。

ソースはこんな感じ↓。

Option Explicit
'テストモード制御定数。納品時はすべて False にすること。
Const B_TEST As Boolean = False
Const B_SHOW As Boolean = False
Const B_NOPRINT As Boolean = False

Const S_LEVELBASE = "A7"
Const I_OFFSET = 4 '2つの表の間が何行あるか。表の最後から、次の表のラベルまでの行数を書く

Dim rLev As Range
Dim sz As Long
Dim mj As Boolean
Dim fs As Double
Dim fx As Long
Dim ma As Long
Dim nm As String
Dim cf As String
Dim ct As Long
Dim pn As String
Dim fl As String
Dim ht As Double
Dim wt As Double
Dim kt As String
Public Sub main()
    Randomize
    
    Set rLev = Range("LEVELBASE").Offset(Range("LEVEL").Value)
    With rLev
        sz = .Offset(, 1).Value
        mj = .Offset(, 2).Value
    End With
    fs = Range("SMALL").Value
    fx = Range("LARGE").Value
    nm = Range("CELLFONT").Value
    ma = Range("REPEAT").Value
    ct = Range("COPIES").Value
    pn = Range("PRINTERNAME").Value
    fl = Range("LEVELFONT").Value
    ht = Range("CELLHEIGHT").Value
    wt = Range("CELLWIDTH").Value
    cf = Range("SCOREFONT").Value
    kt = Range("KITEN").Value
    
    Dim c As Long
    For c = 1 To ma
        MainRoutine c
    Next
End Sub
Private Sub MainRoutine(kazu As Long)
    Dim a As Application
    Set a = Application
    Dim s As Worksheet
    Set s = spre
    With s
        a.ScreenUpdating = B_SHOW
        With .UsedRange
            .ClearContents
            .ClearFormats
            .RowHeight = s.StandardHeight
            .ColumnWidth = s.StandardWidth
        End With
        SetHyo .Range(kt), kazu * 2 - 1
        SetHyo .Range(kt).Offset(sz * 2 + I_OFFSET + 1), kazu * 2
        a.ScreenUpdating = True
        
        With .PageSetup
            .FitToPagesWide = 1
            .FitToPagesTall = 1
            .CenterHorizontally = True
            .CenterVertically = True
            If Not B_TEST And Not B_NOPRINT Then
                .Parent.PrintOut Copies:=ct, ActivePrinter:=pn, Collate:=True
            End If
        End With
    End With
End Sub
Private Sub SetHyo(rBs As Range, num As Long)
    With rBs
        .Value = "【LEVEL " & rLev.Value & "-" & num & "】"
        .Font.Name = fl
        .Font.Size = fs
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
    Set rBs = rBs.Offset(2)
    With rBs
        With Range(.Offset(0, 0), .Offset(sz * 2 + 2, sz * 2 - 1))
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Size = fs
            .RowHeight = ht
            .ColumnWidth = wt
            .Font.Name = nm
        End With
        With Range(.Offset(sz * 2 + 1, 0), .Offset(sz * 2 + 1, sz * 2 - 1))
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .MergeCells = True
            .Font.Name = cf
            Select Case sz
                Case 4
                    .Value = "１回目（　 ）秒 ２回目（ 　）秒 ３回目（ 　）秒"
                Case 5
                    .Value = "１回目（　　）秒　２回目（　　）秒　３回目（　　）秒"
                Case 6
                    .Value = "１回目（　 　）秒　　２回目（　　 ）秒　　３回目（　 　）秒"
                Case 7
                    .Value = "１回目（　　　）秒　　２回目（　　　）秒　　３回目（　　　）秒"
            End Select
            .ShrinkToFit = True
        End With
        Dim c As Long
        For c = 0 To sz ^ 2 - 1
            SetFormatValue rLev, .Offset((c \ sz) * 2, (c Mod sz) * 2), fx
        Next
        Dim rA As Range
        Set rA = .Offset((0 \ sz) * 2, (0 Mod sz) * 2)
        For c = 0 To sz ^ 2 - 1
            Set rA = Union(rA, .Offset((c \ sz) * 2, (c Mod sz) * 2))
        Next
        Dim r As Range
        c = 0
        With rand
            SetNumList .Range("A1"), sz ^ 2, mj
            For Each r In rA
                SetEntry r, .Range("A1").Offset(c + 1).Value
                c = c + 1
            Next
        End With
    End With
End Sub
Private Sub SetFormatValue(rL As Range, rTgt As Range, fxx As Long)
    Dim cLev(2) As Long
    With rL
        cLev(0) = .Offset(, 3).Value
        cLev(1) = .Offset(, 4).Value
        cLev(2) = .Offset(, 5).Value
    End With

    Select Case Int((cLev(0) + cLev(1) + cLev(2)) * Rnd + 1)
        Case 0 To cLev(0)
            rTgt.Font.Size = fxx
        Case cLev(0) + 1 To cLev(0) + cLev(1)
        Case cLev(0) + cLev(1) + 1 To cLev(0) + cLev(1) + cLev(2)
            Nuri rTgt
    End Select
End Sub
Private Sub Nuri(rT As Range)
    Dim b2 As Boolean
    Dim rBlack As Range
    Dim num As Long
    b2 = Rnd() * 2 > 1
    With rand
        SetNumList .Range("D1"), 4, mj
        num = .Range("D1").Offset(1).Value - 1
        Set rBlack = rT.Offset(num \ 2, num Mod 2)
        If b2 Then
            num = .Range("D2").Offset(1).Value - 1
            Set rBlack = Union(rBlack, rT.Offset(num \ 2, num Mod 2))
        End If
        rBlack.Interior.Color = vbBlack
    End With
End Sub
Private Function Neco(r1 As Range, r2 As Range) As Range
    Set Neco = IIf(Rnd() > 0.5, r1, r2)
End Function
'Private Function Mg(r1 As Range, r2 As Range) As Range
'    Set Mg = Range(r1, r2)
'    Range(r1, r2).MergeCells = True
'End Function
Private Function IsBk(rT As Range) As Boolean
    IsBk = rT.Interior.Color = vbBlack
End Function
Private Function CountBk(rA As Range) As Integer
    Dim c As Boolean
    Dim r As Range
    Dim rRet As Range
    For Each r In rA
        If IsBk(r) Then
            If rRet Is Nothing Then
                Set rRet = r
            Else
                Set rRet = Union(rRet, r)
            End If
        End If
    Next
    If rRet Is Nothing Then
        CountBk = 0
    Else
        CountBk = rRet.Count
    End If
End Function
Private Sub SetEntry(rg As Range, v As Variant)
    Dim rAll As Range
    Dim rA(3) As Range
    With rg
        Set rA(0) = .Offset(0, 0)
        Set rA(1) = .Offset(1, 0)
        Set rA(2) = .Offset(0, 1)
        Set rA(3) = .Offset(1, 1)
        Set rAll = Range(rA(0), rA(3))
    End With
    With rAll
        Kei .Borders(xlEdgeLeft), .Borders(xlEdgeTop), .Borders(xlEdgeBottom), .Borders(xlEdgeRight)
    End With
    
    Dim rRet As Range
    Select Case CountBk(rAll)
        Case 0
            Set rRet = rAll
        Case 1
            If IsBk(rA(0)) Or IsBk(rA(3)) Then
                Set rRet = IIf( _
                        IsBk(rA(0)), _
                        Range(Neco(rA(1), rA(2)), rA(3)), _
                        Range(Neco(rA(1), rA(2)), rA(0)) _
                    )
                '↓以下ではバグが発生した
'                Set rRet = IIf( _
'                        IsBk(rA(0)), _
'                        Mg(Neco(rA(1), rA(2)), rA(3)), _
'                        Mg(Neco(rA(1), rA(2)), rA(0)) _
'                    )
            Else
                Set rRet = IIf( _
                                IsBk(rA(1)), _
                                Range(Neco(rA(0), rA(3)), rA(2)), _
                                Range(Neco(rA(0), rA(3)), rA(1)) _
                            )
            End If
        Case 2
            If IsBk(rA(0)) And IsBk(rA(3)) Then
                Set rRet = Neco(rA(1), rA(2))
            ElseIf IsBk(rA(1)) And IsBk(rA(2)) Then
                Set rRet = Neco(rA(0), rA(3))
            ElseIf Not IsBk(rA(0)) Then
                Set rRet = IIf( _
                            IsBk(rA(1)), _
                            Range(rA(0), rA(1)), _
                            Range(rA(0), rA(2)) _
                        )
                '↓以下ではバグが発生した
'                Set rRet = IIf( _
'                            IsBk(rA(1)), _
'                            Mg(rA(0), rA(1)), _
'                            Mg(rA(0), rA(2)) _
'                        )
            Else
                Set rRet = IIf( _
                            IsBk(rA(1)), _
                            Range(rA(2), rA(3)), _
                            Range(rA(1), rA(3)) _
                        )
            End If
    End Select
    With rRet
        If .Count > 1 Then
            .MergeCells = True
        End If
        .Value = v
    End With
End Sub
Private Sub Kei(ParamArray ba() As Variant)
    Dim b As Variant
    For Each b In ba
        With b
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlMedium
        End With
    Next
End Sub
Private Sub SetNumList(rBs As Range, mx As Long, tpe As Boolean)
    Dim c As Long
    With rBs
        .CurrentRegion.Offset(1).ClearContents
        For c = 1 To mx
            .Offset(c, 0).Value = IIf(tpe, c, .Offset(c, 6).Value)
            .Offset(c, 1).Value = Int(Rnd * mx * 1000) + 1
        Next
        .Sort Key1:=.Offset(, 1), Order1:=xlAscending, Header:=xlYes
    End With
End Sub

↑「以下ではバグが発生した」のところについて補足すると…。

詳しくは調べていないのですが、Iif 関数の第二引数内でセルを結合させるメソッド(VBAではプロパティ扱いですが、やってることはメソッドですね (^^; )を含めると、Iif関数の真偽の値が反転するか、必ず真になるかするようです。
マニアックな話題ですが、そのうち気が向いたらもっと調査したいと思います。
バグなんじゃないかな。