'キーボードで罫線を引くマクロ 'このツールでは罫線を重ねて引くことはできません。 '(例えば縦罫線は必ず左右どちらかのセルの罫線になります。) 'Excel5.0、Excel95で動作します。 'MakeToolbarマクロを実行して罫線キーツールバーを作成し、 '[罫線キーの開始]ボタンをクリックしてください。 '終了するには[罫線キーの終了]ボタンをクリックしてください。 'キー操作 'Ctrl+矢印キー: セルカーソルの左上隅で左または上の罫線を引きます。 'Alt+矢印キー:セルカーソルの右下隅で右または下の罫線を引きます。 'Ctrl+空白:選択範囲に外枠線を引きます。 'Ctrl+BackSpace:選択範囲の罫線をすべて消去します。 'Ctrl+9:罫線キーの設定(ダイアログボックスで外枠線(または左罫線)を設定してください。) 'Ctrl+0:外枠線の設定(ダイアログボックスで外枠線(または左罫線)を設定してください。) Option Explicit '罫線の初期設定 Const defaultBorderLineStyle0 = xlDot Const defaultBorderWeight0 = 0 Const defaultBorderColor0 = 5 '外枠線の初期設定 Const defaultBorderLineStyle1 = xlContinuous Const defaultBorderWeight1 = xlMedium Const defaultBorderColor1 = 5 Dim BorderLineStyle(0 To 1) As Integer Dim BorderWeight(0 To 1) As Integer Dim BorderColor(0 To 1) As Integer '罫線キーモードを開始するマクロ Sub BorderKey_On() Application.OnKey "^{LEFT}", "'BorderKey 1'" Application.OnKey "^{RIGHT}", "'BorderKey 2'" Application.OnKey "^{UP}", "'BorderKey 3'" Application.OnKey "^{DOWN}", "'BorderKey 4'" Application.OnKey "%{LEFT}", "'BorderKey 5'" Application.OnKey "%{RIGHT}", "'BorderKey 6'" Application.OnKey "%{UP}", "'BorderKey 7'" Application.OnKey "%{DOWN}", "'BorderKey 8'" Application.OnKey "^ ", "BorderKeyAround" Application.OnKey "^{BS}", "BorderClearAll" Application.OnKey "^9", "'BorderKeySetStyle 0'" Application.OnKey "^0", "'BorderKeySetStyle 1'" End Sub '罫線キーモードを終了するマクロ Sub BorderKey_Off() Application.OnKey "^{LEFT}" Application.OnKey "^{RIGHT}" Application.OnKey "^{UP}" Application.OnKey "^{DOWN}" Application.OnKey "%{LEFT}" Application.OnKey "%{RIGHT}" Application.OnKey "%{UP}" Application.OnKey "%{DOWN}" Application.OnKey "^ " Application.OnKey "^{BS}" Application.OnKey "^9" Application.OnKey "^0" End Sub '罫線を引くマクロ Sub BorderKey(ByVal index1 As Integer) Dim flag As Boolean, flag2 As Boolean Dim i As Long, j As Long, i2 As Long, j2 As Long Dim index2 As Integer, index3 As Integer Dim obj As Object If TypeName(Selection) <> "Range" Then Exit Sub Select Case index1 Case 1 i = 0: j = -1: index2 = xlTop: flag = True i2 = -1: j2 = 0: index3 = xlBottom Case 2 i = 0: j = 1: index2 = xlTop: flag = False i2 = -1: j2 = 0: index3 = xlBottom Case 3 i = -1: j = 0: index2 = xlLeft: flag = True i2 = 0: j2 = -1: index3 = xlRight Case 4 i = 1: j = 0: index2 = xlLeft: flag = False i2 = 0: j2 = -1: index3 = xlRight Case 5 i = 0: j = -1: index2 = xlBottom: flag = False i2 = 1: j2 = 0: index3 = xlTop Case 6 i = 0: j = 1: index2 = xlBottom: flag = True i2 = 1: j2 = 0: index3 = xlTop Case 7 i = -1: j = 0: index2 = xlRight: flag = False i2 = 0: j2 = 1: index3 = xlLeft Case Else i = 1: j = 0: index2 = xlRight: flag = True i2 = 0: j2 = 1: index3 = xlLeft End Select InitParams On Error GoTo err_1 If flag Then ActiveCell.Offset(i, j).Select Set obj = Nothing On Error Resume Next Set obj = ActiveCell.Offset(i2, j2).Borders(index3) On Error GoTo err_1 If obj Is Nothing Then flag2 = True Else flag2 = (obj.LineStyle = xlNone) End If With ActiveCell.Borders(index2) If (.LineStyle = xlNone) And flag2 Then .LineStyle = BorderLineStyle(0) If BorderLineStyle(0) = xlContinuous Then _ .Weight = BorderWeight(0) .ColorIndex = BorderColor(0) Else .LineStyle = xlNone End If End With If Not (obj Is Nothing) Then obj.LineStyle = xlNone If Not flag Then ActiveCell.Offset(i, j).Select Exit Sub err_1: End Sub '罫線設定のマクロ Sub BorderKeySetStyle0() BorderKeySetStyle 0 End Sub Sub BorderKeySetStyle1() BorderKeySetStyle 1 End Sub Sub BorderKeySetStyle(index1 As Integer) Dim obj As Object Dim stat As Integer InitParams 'MsgBox "次に表示するダイアログボックスで、" & _ "外枠または左罫線を設定してください。", vbInformation, "罫線の設定" stat = ActiveWindow.WindowState Set obj = CreateObject("Excel.Sheet") ActiveWindow.WindowState = stat ActiveWindow.Caption = "外枠または左罫線を設定してください。" ActiveSheet.Cells(2, 2).Select If BorderLineStyle(index1) = xlContinuous Then ActiveCell.BorderAround Weight:=BorderWeight(index1), _ ColorIndex:=BorderColor(index1) Else ActiveCell.BorderAround LineStyle:=BorderLineStyle(index1), _ ColorIndex:=BorderColor(index1) End If If Application.Dialogs(xlDialogBorder).Show Then With ActiveCell.Borders(xlLeft) BorderLineStyle(index1) = .LineStyle If BorderLineStyle(index1) = xlContinuous Then _ BorderWeight(index1) = .Weight BorderColor(index1) = .ColorIndex End With End If Set obj = Nothing End Sub '選択範囲に外枠罫線を引くマクロ Sub BorderKeyAround() Dim flag As Boolean If TypeName(Selection) <> "Range" Then Exit Sub InitParams On Error Resume Next With Selection flag = (.Cells(1, 1).Borders(xlLeft).LineStyle = xlNone) flag = flag And (.Cells(1, 0).Borders(xlRight).LineStyle = xlNone) .Rows(1).Offset(-1).Borders(xlBottom).LineStyle = xlNone .Rows(.Rows.Count).Offset(1).Borders(xlTop).LineStyle = xlNone .Columns(1).Offset(, -1).Borders(xlRight).LineStyle = xlNone .Columns(.Columns.Count).Offset(, 1).Borders(xlLeft).LineStyle = xlNone End With On Error GoTo 0 If flag Then Select Case BorderLineStyle(1) Case xlContinuous Selection.BorderAround Weight:=BorderWeight(1), _ ColorIndex:=BorderColor(1) Case xlNone With Selection .Rows(1).Borders(xlTop).LineStyle = xlNone .Rows(.Rows.Count).Borders(xlBottom).LineStyle = xlNone .Columns(1).Borders(xlLeft).LineStyle = xlNone .Columns(.Columns.Count).Borders(xlRight).LineStyle = xlNone End With Case Else Selection.BorderAround LineStyle:=BorderLineStyle(1), _ ColorIndex:=BorderColor(1) End Select Else With Selection .Rows(1).Borders(xlTop).LineStyle = xlNone .Rows(.Rows.Count).Borders(xlBottom).LineStyle = xlNone .Columns(1).Borders(xlLeft).LineStyle = xlNone .Columns(.Columns.Count).Borders(xlRight).LineStyle = xlNone End With End If End Sub '選択範囲の罫線を消去するマクロ Sub BorderClearAll() Dim r As Range If TypeName(Selection) <> "Range" Then Exit Sub Selection.Borders.LineStyle = xlNone On Error Resume Next For Each r In Selection.Areas r.Rows(1).Offset(-1).Borders(xlBottom).LineStyle = xlNone r.Rows(r.Rows.Count).Offset(1).Borders(xlTop).LineStyle = xlNone r.Columns(1).Offset(, -1).Borders(xlRight).LineStyle = xlNone r.Columns(r.Columns.Count).Offset(, 1).Borders(xlLeft).LineStyle = xlNone Next End Sub '罫線設定を初期化するマクロ Sub InitParams() If BorderLineStyle(0) = 0 Then BorderLineStyle(0) = defaultBorderLineStyle0 BorderWeight(0) = defaultBorderWeight0 End If If BorderColor(0) = 0 Then BorderColor(0) = defaultBorderColor0 If BorderLineStyle(1) = 0 Then BorderLineStyle(1) = defaultBorderLineStyle1 BorderWeight(1) = defaultBorderWeight1 End If If BorderColor(1) = 0 Then BorderColor(1) = defaultBorderColor1 End Sub '罫線キーツールバーを作成するマクロ Sub MakeToolbar() Dim s As String With Application s = "キーボードで罫線を引くモードを開始します。" .MacroOptions Macro:="BorderKey_On", Description:=s, _ HasShortcutKey:=True, ShortcutKey:="l", StatusBar:=s s = "キーボードで罫線を引くモードを終了します。" .MacroOptions Macro:="BorderKey_Off", Description:=s, _ HasShortcutKey:=True, ShortcutKey:="L", StatusBar:=s s = "選択範囲に外枠線を引きます。" .MacroOptions Macro:="BorderKeyAround", StatusBar:=s s = "選択範囲の罫線を消去します。" .MacroOptions Macro:="BorderClearAll", StatusBar:=s s = "罫線の種類を設定します。" .MacroOptions Macro:="BorderKeySetStyle0", StatusBar:=s s = "外枠線の種類を設定します。" .MacroOptions Macro:="BorderKeySetStyle1", StatusBar:=s End With With Toolbars.Add(Name:="罫線キー") With .ToolbarButtons .Add(Button:=211, Before:=1, OnAction:="BorderKey_On").Name = "罫線キーの開始" .Add(Button:=212, Before:=2, OnAction:="BorderKey_Off").Name = "罫線キーの終了" .Add(Button:=222, Before:=3, OnAction:="BorderKeyAround").Name = "外枠線" .Add(Button:=223, Before:=4, OnAction:="BorderClearAll").Name = "罫線消去" .Add(Button:=97, Before:=5, OnAction:="BorderKeySetStyle0").Name = "罫線キーの設定" .Add Button:=0, Before:=5 .Add(Button:=97, Before:=7, OnAction:="BorderKeySetStyle1").Name = "外枠線の設定" End With .Visible = True End With End Sub