'あみだくじマクロサンプル

'SampleSheetAdd()マクロを実行するとテストシートが作成されます。

'使用上の注意
'1. 罫線は自動的に調整（削除、左と下罫線への統一）されます。
'2. 名前を記入するセルはロックを解除してください。
'3. シート作成後はシート保護を行ってください。
'   最初の結果表示時にシート保護解除のダイアログが表示されます。
'   それ以降、自動的にパスワードなしでシート保護されます。

Option Explicit

Const BorderColorDefault = xlAutomatic
Const BorderColorTrace = 3
Const WaitLoopCount = 100000

Sub SelectionDo()
    If ActiveCell.Locked Then Exit Sub
    ActiveSheet.Unprotect
    ActiveSheet.Protect userinterfaceOnly:=True
    Cells.EntireRow.Hidden = False
    InitBorders
    AmidaWalk ActiveCell
End Sub

Sub AmidaNext(ByRef range1 As Range, rowOffset As Integer, _
        columnOffset As Integer, borderIndex As Integer, _
        value1 As Variant)
    Dim i As Long
    range1.ClearContents
    Set range1 = range1.Offset(rowOffset, columnOffset)
    range1.Value = value1
    If borderIndex <> 0 Then
        With range1.Borders(borderIndex)
            If .LineStyle <> xlNone Then .ColorIndex = BorderColorTrace
        End With
    End If
    For i = 1 To WaitLoopCount: Next
End Sub

Sub AmidaWalk(range1 As Range)
    Dim r As Range
    Dim v

    '罫線色の初期化
    For Each r In range1.Worksheet.UsedRange.Cells
        With r.Borders(xlLeft)
            If .LineStyle <> xlNone Then .ColorIndex = BorderColorDefault
        End With
        With r.Borders(xlBottom)
            If .LineStyle <> xlNone Then .ColorIndex = BorderColorDefault
        End With
    Next

    v = range1.Value
    Set r = range1.Cells(2, 1)
    AmidaNext r, 0, 0, xlLeft, v
    Do While True
        If r.Borders(xlLeft).LineStyle = xlNone Then
            Exit Do
        ElseIf r.Borders(xlBottom).LineStyle <> xlNone Then
            AmidaNext r, 0, 0, xlBottom, v
            AmidaNext r, 0, 1, 0, v
        ElseIf r.Offset(0, -1).Borders(xlBottom).LineStyle <> xlNone Then
            AmidaNext r, 0, -1, xlBottom, v
        End If
        AmidaNext r, 1, 0, xlLeft, v
        r.Select
    Loop
End Sub

Sub InitBorders()
    Dim r As Range
    Dim obj As Border
    ActiveSheet.Rows(1).Borders.LineStyle = xlNone
    ActiveSheet.Columns(1).Borders.LineStyle = xlNone
    For Each r In ActiveSheet.UsedRange.Offset(1, 1).Cells
        With r.Borders(xlRight)
            If .LineStyle <> xlNone Then
                Set obj = r.Offset(0, 1).Borders(xlLeft)
                If .LineStyle = xlContinuous Then
                   obj.Weight = .Weight
                Else
                   obj.LineStyle = .LineStyle
                End If
                obj.Color = .Color
                .LineStyle = xlNone
            End If
        End With
        With r.Borders(xlTop)
            If .LineStyle <> xlNone Then
                Set obj = r.Offset(-1, 0).Borders(xlBottom)
                If .LineStyle = xlContinuous Then
                   obj.Weight = .Weight
                Else
                   obj.LineStyle = .LineStyle
                End If
                obj.Color = .Color
                .LineStyle = xlNone
            End If
        End With
    Next
End Sub

Sub SampleSheetAdd()
    Worksheets.Add
    Range("A1").Value = "あみだくじマクロサンプル"
    Range("A3").Value = "名前1〜の中からセルを1つ選んで、自分の名前を上書きしてください。"
    Range("A4").Value = "結果の確認は、名前のセルを選択し、実行ボタンを押します。"
    Range("B8").Value = "名前1"
    Range("B8").AutoFill Range("B8:F8")
    Range("B8:F8").Locked = False
    Range("B21").Value = "景品1"
    Range("B21").AutoFill Range("B21:F21")
    With Range("A6")
        With ActiveSheet.Buttons.Add(.Left, .Top, .Width, .Height)
            .Text = "実行"
            .OnAction = "SelectionDo"
        End With
    End With
    Range("B9:F19").Borders(xlLeft).Weight = xlMedium
    Range("B11,B12,B15,B17,C13,C18,D11,D15,E14,E17") _
        .Borders(xlBottom).Weight = xlMedium
    Range("A1:F21").Select
    ActiveWindow.Zoom = True
    Range("A1").Select
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.DisplayHeadings = False
    Rows("10:18").Hidden = True
    ActiveSheet.Protect
End Sub