朝の散歩も暑い。９月なのにこの暑さはどうなっているという顔をしている柴犬です。
概要
次の画像のような列幅の狭小な excel のシートを編集は、そのまま人力で行おうとすると結構気を使います。
年寄りには、目がチカチカしてとても困難な仕事になります。
そこで、少しでも楽ができる編集ツールを考えてみました。
私が使っている教科書です。
ツールの方針
１．フォーム操作で行えること
２．選択した領域の列幅が変更できること
３．領域がフォームから指定選択できること
４．罫線、アライメント、マージができること
５．選択範囲が左右上下、移動できること など
６．１紙面の推測範囲は、シートの左から列幅が0.5未満の範囲とします。0.5はコードの中で適宜変えることができます。
７．編集のセルの列範囲は、１紙面の推測範囲のパーセントで指定できるようにする。
以上により、次のようなフォームとしました。
Visual Basic エディターでのフォームの編集がめんです。
フォーム上のコントロールの種類と名前は次のようにしています。
ソースコード
シートに書くコードになります。
フォームから選択範囲が読み取れるように、プロパティを作成しています。
マウスのダブルクリックまたは右クリックでフォーム「UserForm1」が開くようにしています。
ただ、通常のメニューが開くようにしたいので、ここではセル「A1」が何かデータが入っていればフォームが開くようにしています。
Option Explicit
Private memAreatop As Long
Private memArealeft As Long
Private memAreawidth As Long
Private memAreaheight As Long
Public Property Get Areatop() As Long
Areatop = memAreatop
End Property
Public Property Get Arealeft() As Long
Arealeft = memArealeft
End Property
Public Property Get Areawidth() As Long
Areawidth = memAreawidth
End Property
Public Property Get Areaheight() As Long
Areaheight = memAreaheight
End Property
Public Property Get ColWidth() As String
ColWidth = Format(Selection.Item(1).ColumnWidth, "0.###")
End Property
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Cells(1, 1).Value = "" Then
Exit Sub
End If
Cancel = True
With Selection
memAreatop = .Item(1).Row
memArealeft = .Item(1).Column
memAreawidth = .Item(.Count).Column - .Item(1).Column + 1
memAreaheight = .Item(.Count).Row - .Item(1).Row + 1
End With
UserForm1.Show
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Cells(1, 1).Value = "" Then
Exit Sub
End If
Cancel = True
With Selection
memAreatop = .Item(1).Row
memArealeft = .Item(1).Column
memAreawidth = .Item(.Count).Column - .Item(1).Column + 1
memAreaheight = .Item(.Count).Row - .Item(1).Row + 1
End With
UserForm1.Show
End Sub
フォーム「UserForm1」に書くコードになります。
Option Explicit
Private scol As Long
Private ecol As Long
Private VarAlign As Dictionary
Private HoriAlign As Dictionary
Private Target As Range
Private Sub di_Click()
Call incRangeSet("down")
End Sub
Private Sub ui_Click()
Call incRangeSet("up")
End Sub
Private Sub li_Click()
Call incRangeSet("left")
End Sub
Private Sub ri_Click()
Call incRangeSet("right")
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
With ActiveSheet
Me.tval.Value = .Areatop
Me.lval.Value = .Arealeft
Me.wval.Value = .Areawidth
Me.hval.Value = .Areaheight
Me.cval.Value = .ColWidth
End With
Call ColSet
Set HoriAlign = New Dictionary
With HoriAlign
.Add "標準", xlGeneral
.Add "左詰め", xlLeft
.Add "中央揃え", xlCenter
.Add "右詰め", xlRight
.Add "繰り返し", xlFill
.Add "両端揃え", xlJustify
.Add "選択範囲内で中央", xlCenterAcrossSelection
.Add "均等割り付け", xlDistributed
End With
Set VarAlign = New Dictionary
With VarAlign
.Add "上詰め ", xlTop
.Add "中央揃え ", xlCenter
.Add "下詰め ", xlBottom
.Add "繰り返し ", xlFill
.Add "両端揃え ", xlJustify
.Add "均等割り付け ", xlDistributed
End With
Dim val As Variant
With Me.halign
For Each val In HoriAlign.Keys
.AddItem val
Next val
End With
With Me.valign
For Each val In VarAlign.Keys
.AddItem val
Next val
End With
Call RangeSet
Me.content.Value = Target.Cells(1, 1).Value
End Sub
Private Sub lp_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If IsNumeric(Me.lp.Value) Then
Me.lval.Value = Int(CDbl(Me.lp.Value) * (ecol - scol + 1) / 100)
End If
Call RangeSet
End Sub
Private Sub wp_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If IsNumeric(Me.wp.Value) Then
Me.wval.Value = Int(CDbl(Me.wp.Value) * (ecol - scol + 1) / 100)
End If
Call RangeSet
End Sub
Private Sub セット_Click()
With ActiveSheet
.Range(.Cells(1, CInt(Me.lval.Value)), _
.Cells(1, CInt(Me.lval.Value) + CInt(Me.wval.Value) - 1)).ColumnWidth = CDbl(Me.cval.Value)
End With
Call ColSet
Me.cval.Value = Target.Cells(1, 1).ColumnWidth
End Sub
Private Sub 実行_Click()
Call RangeSet(True)
With Target.Borders(xlEdgeTop)
Select Case True
Case Me.tlh
.Weight = xlHairline
Case Me.tlm
.Weight = xlThin
Case Me.tlb
.Weight = xlMedium
Case Me.tlno
.LineStyle = xlNone
Case Me.tlf.Value
'何もしません
End Select
End With
With Target.Borders(xlEdgeRight)
Select Case True
Case Me.rlh
.Weight = xlHairline
Case Me.rlm
.Weight = xlThin
Case Me.rlb
.Weight = xlMedium
Case Me.rlno
.LineStyle = xlNone
Case Me.rlf.Value
'何もしません
End Select
End With
With Target.Borders(xlEdgeBottom)
Select Case True
Case Me.blh
.Weight = xlHairline
Case Me.blm
.Weight = xlThin
Case Me.blb
.Weight = xlMedium
Case Me.blno
.LineStyle = xlNone
Case Me.blf.Value
'何もしません
End Select
End With
With Target.Borders(xlEdgeLeft)
Select Case True
Case Me.llh
.Weight = xlHairline
Case Me.llm
.Weight = xlThin
Case Me.llb
.Weight = xlMedium
Case Me.llno
.LineStyle = xlNone
Case Me.llf.Value
'何もしません
End Select
End With
With Target
.MergeCells = Me.merg.Value
.WrapText = Me.rap.Value
.ShrinkToFit = Me.fit.Value
If Me.halign.Value = "" Then
.HorizontalAlignment = xlGeneral
Else
If HoriAlign.Exists(Me.halign.Value) Then
.HorizontalAlignment = HoriAlign(Me.halign.Value)
Else
.HorizontalAlignment = xlGeneral
End If
End If
If Me.valign.Value = "" Then
.VerticalAlignment = xlCenter
Else
If VarAlign.Exists(Me.valign.Value) Then
.VerticalAlignment = VarAlign(Me.valign.Value)
Else
.VerticalAlignment = xlCenter
End If
End If
.AddIndent = False
.IndentLevel = 0
End With
Target.Cells(1, 1).Value = Me.content.Value
End Sub
Private Sub 閉じる_Click()
Unload Me
End Sub
Private Sub ColSet()
Dim i As Long
With ActiveSheet
scol = 0
ecol = 0
For i = 1 To .Columns.Count
If .Cells(1, i).ColumnWidth < 0.5 Then
If scol = 0 Then
scol = i
End If
ecol = i
Else
If scol > 0 Then
i = .Columns.Count
End If
End If
Next i
End With
End Sub
Private Sub RangeSet(Optional ByVal resetflg As Boolean = False)
If resetflg Then
With Target
.MergeCells = False
.ClearContents
End With
End If
With ActiveSheet
Set Target = .Range(.Cells(CInt(Me.tval.Value), _
CInt(Me.lval.Value)), _
.Cells(CInt(Me.tval.Value) + CInt(Me.hval.Value) - 1, _
CInt(Me.lval.Value) + CInt(Me.wval.Value) - 1))
End With
Target.Select
End Sub
Private Sub incRangeSet(ByVal flg As String)
Dim h As Long
Dim v As Long
With Target
.MergeCells = False
.ClearContents
End With
h = 0
v = 0
Select Case flg
Case "left"
If CInt(Me.lval.Value) >= 2 Then
h = -1
End If
Case "right"
h = 1
Case "up"
If CInt(Me.tval.Value) >= 2 Then
v = -1
End If
Case "down"
v = 1
End Select
Me.tval.Value = CInt(Me.tval.Value) + v
Me.lval.Value = CInt(Me.lval.Value) + h
With ActiveSheet
Set Target = .Range(.Cells(CInt(Me.tval.Value), _
CInt(Me.lval.Value)), _
.Cells(CInt(Me.tval.Value) + CInt(Me.hval.Value) - 1, _
CInt(Me.lval.Value) + CInt(Me.wval.Value) - 1))
End With
Target.Select
End Sub