Option Explicit
'+++*****************************************************+++
' ワークシート比較ツール【比較結果】シートを作成
'+++*****************************************************+++
Public Sub MakeResultSht()
Dim i As Long
Dim j As Long
Dim MaxRow As Long '最終行
Dim MaxCol As Long '最終列
Dim IngColor As Long
Dim rHeight() As Variant
Dim cWidth() As Variant
Dim rowAry() As Variant
Dim colAry() As Variant
Dim strAry() As Variant
Dim ColWidth As Double
Dim bstrWidth As Double
Dim mgnWidth As Double
Dim aWdt As Double 'ColumnWidth = 10 :Width
Dim bWdt As Double 'ColumnWidth = 20 :Width
Dim cWdt As Double 'ColumnWidth = 1 :Width
Dim oneDW As Double 'ColumnWidth = 1 :Width
Dim pOneDw As Double 'ColumnWidth = 0.1 :Width
Dim myInteger As Double
Dim myDecimal As Double
Dim myCW As Double
Dim wbName As String
Dim rstSht As Worksheet
Dim IsBlank As Boolean
Const shtName As String = "比較結果"
Const TTLSTRCOLOR As Long = 11580416 'タイトル文字色
Const BGCOLOR As Long = 10192433 '青緑
Const LBCOLOR As Long = 16247773 '薄めの青
Const LGCOLOR As Long = 15921906 'ライトグレー
Const LINECOLOR As Long = 10921638 'ライトグレー2
Const MYCOLOR1 As Long = 6299648 '紺
Const MYCOLOR2 As Long = 14772545 '青
Const MYCOLOR3 As Long = 13749760 'エメラルド
rHeight = Array(0, 7.5, 25.5, 1.5, 5, 2, 13.5, 2.5, 27.5, 7, 27.5, 9.5, _
19, 19, 19, 7.5, 14, 4, 19, 13.5)
' cWidth = Array(0, 0.63, 0.63, 5, 6.4, 15.67, 15.67, 0.63, 0.63, 5, 6.4, _
' 15.67, 15.67, 0.63, 0.63, 5, 6.4, 16, 16, 0.63, 0.63)
cWidth = Array(0, 7.5, 7.5, 42, 52.5, 122, 122, 7.5, 7.5, 42, 52.5, _
122, 122, 7.5, 7.5, 42, 52.5, 124.5, 124.5, 7.5, 7.5)
rowAry = Array(0, 2, 2, 2, 8, 10, 12, 12, 12, 12, 12, 12, _
13, 13, 13, 14, 14, 14, 16, 16, 16, 18, 18, 18, 18, 18, 18, _
18, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19)
colAry = Array(0, 4, 12, 13, 3, 3, 3, 5, 9, 11, 15, 17, 5, _
11, 17, 3, 9, 15, 3, 9, 15, 3, 4, 5, 6, 7, 9, 10, 11, 12, _
13, 15, 16, 17, 18, 19, 3, 9, 15)
strAry = Array(0, "シート比較結果", "Ver.1.0", _
"比較実行日時", "比較ファイル①", "比較ファイル②", "a", _
"比較セル数", "b", "比較セル数", "c", "比較セル数", _
"不一致件数", "不一致件数", "不一致件数", _
"比較元 シート名", "比較元 シート名", "比較元 シート名", _
"不一致セル、値(1,000件まで)", _
"不一致セル、値(1,000件まで)", _
"不一致セル、値(1,000件まで)", "NO", "セル位置", _
"a ①(値)", "a ②(値)", " ", "NO", "セル位置", _
"b ①(値)", "b ②(値)", " ", "NO", "セル位置", _
"c ①(値)", "c ②(値)", " ", "1", "1", "1")
Call StopUpdating
wbName = ActiveWorkbook.Name
'******************************************************************************
'日本語 フォントテーマをMeiryo UIで設定
With ActiveWorkbook.Theme.ThemeFontScheme
.MajorFont.Item(3).Name = "Meiryo UI" '見出しのフォント
.MinorFont.Item(3).Name = "Meiryo UI" '本文のフォント
End With
'******************************************************************************
IsBlank = False
If IsShtOwb(shtName, wbName) = False Then
With Worksheets(1)
With .UsedRange
MaxRow = .Rows(.Rows.Count).Row
MaxCol = .Columns(.Columns.Count).Column
End With
End With
If MaxRow = 1 And MaxCol = 1 Then
IsBlank = True
End If
If IsBlank Then
Worksheets(1).Name = shtName
Else
ActiveWorkbook.Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = shtName
End If
Else
With ActiveWorkbook.Worksheets(shtName)
.Select
.Cells.Clear
End With
Call delShapes
End If
Set rstSht = ActiveWorkbook.Worksheets(shtName)
With rstSht
.Select
.Cells.VerticalAlignment = xlCenter
ActiveWindow.FreezePanes = False
.Cells(19, 1).Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 85
With .Cells.Font
.ThemeFont = xlThemeFontNone
.Name = "Meiryo UI"
.Size = 10
End With
'*********************************************
'フォントテーマが " Meiryou UI"でなくても
'列幅を正しく反映させるための処理
.Columns(1).ColumnWidth = 10
.Columns(2).ColumnWidth = 20
.Columns(3).ColumnWidth = 1
aWdt = .Columns(1).Width
bWdt = .Columns(2).Width
cWdt = .Columns(3).Width
mgnWidth = 2 * aWdt - bWdt
bstrWidth = (bWdt - aWdt) / 10 'Width/1文字
oneDW = cWdt
pOneDw = cWdt / 10
'Width が ColumnWidth =1 以下の場合は、
'計算方法を変更
'多少、アバウトになるが、1CWあたりのWidthを比例させて使用
'*********************************************
.Cells.RowHeight = 15.5
.Cells.ColumnWidth = 8.5
For i = 1 To UBound(rHeight)
.Rows(i).RowHeight = rHeight(i)
Next i
For i = 1 To UBound(cWidth)
If cWidth(i) > oneDW Then
myCW = (cWidth(i) - mgnWidth) / bstrWidth
Else
myCW = cWidth(i) / oneDW
End If
.Columns(i).ColumnWidth = myCW
Next i
For i = 1 To UBound(strAry)
.Cells(rowAry(i), colAry(i)).Value = strAry(i)
Next i
.Range("B4:T4").Interior.Color = TTLSTRCOLOR
With .Range("D2").Cells.Font
.Size = 16
.Bold = True
.Color = TTLSTRCOLOR
End With
With .Range("L2").Cells
With .Font
.Size = 12
.Bold = True
.Color = TTLSTRCOLOR
End With
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
'インテンドを1入れる
.InsertIndent 1
End With
With .Range("M2:P2")
.MergeCells = True
.HorizontalAlignment = xlCenter
.Interior.Color = LBCOLOR
End With
.Range("B6:T15").Interior.Color = LBCOLOR
With .Range("C8:D8")
.MergeCells = True
.HorizontalAlignment = xlCenter
.Interior.Color = BGCOLOR
With .Font
.Size = 11
.Bold = True
.Color = vbWhite
End With
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("C10:D10")
.MergeCells = True
.HorizontalAlignment = xlCenter
.Interior.Color = BGCOLOR
With .Font
.Size = 11
.Bold = True
.Color = vbWhite
End With
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("E8:K8")
.MergeCells = True
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 1
.Interior.Color = vbWhite
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("E10:K10")
.MergeCells = True
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 1
.Interior.Color = vbWhite
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("L8,L10")
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 1
.Interior.Color = vbWhite
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("C12:D13")
.MergeCells = True
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 2
.Interior.Color = MYCOLOR1
With .Font
.Size = 20
.Bold = True
.Color = vbWhite
End With
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("I12:J13")
.MergeCells = True
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 2
.Interior.Color = MYCOLOR2
With .Font
.Size = 20
.Bold = True
.Color = vbWhite
End With
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("O12:P13")
.MergeCells = True
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 2
.Interior.Color = MYCOLOR3
With .Font
.Size = 20
.Bold = True
.Color = vbWhite
End With
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("E12,E13,K12,K13,Q12,Q13")
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 1
.Interior.Color = LGCOLOR
.Font.Size = 9
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("C14:D14")
.MergeCells = True
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 1
.Interior.Color = LGCOLOR
.Font.Size = 9
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("I14:J14")
.MergeCells = True
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 1
.Interior.Color = LGCOLOR
.Font.Size = 9
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("O14:P14")
.MergeCells = True
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 1
.Interior.Color = LGCOLOR
.Font.Size = 9
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("F12,F13,L12,L13,R12,R13")
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlRight
.InsertIndent 1
.Interior.Color = vbWhite
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("E14,F14,K14,L14,Q14,R14")
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.InsertIndent 1
.Interior.Color = vbWhite
With .Borders
.LineStyle = xlContinuous
.Color = LINECOLOR
.Weight = xlThin
End With
End With
With .Range("C16:R16")
With .Font
.Size = 9
.Bold = True
.Color = BGCOLOR
End With
End With
With .Range("C18:G18")
.HorizontalAlignment = xlLeft
.Interior.Color = MYCOLOR1
With .Font
.Size = 9
.Bold = True
.Color = vbWhite
End With
End With
.ListObjects.Add(xlSrcRange, Range("$C$18:$G$19"), _
, xlYes).Name = "TableA"
.ListObjects("TableA").TableStyle = "TableStyleLight11"
With .Range("I18:M18")
.HorizontalAlignment = xlLeft
.Interior.Color = MYCOLOR2
With .Font
.Size = 9
.Bold = True
.Color = vbWhite
End With
End With
.ListObjects.Add(xlSrcRange, Range("$I$18:$M$19"), _
, xlYes).Name = "TableB"
.ListObjects("TableB").TableStyle = "TableStyleLight11"
With .Range("O18:S18")
.HorizontalAlignment = xlLeft
.Interior.Color = MYCOLOR3
With .Font
.Size = 9
.Bold = True
.Color = vbWhite
End With
End With
.ListObjects.Add(xlSrcRange, Range("$O$18:$S$19"), _
, xlYes).Name = "TableC"
.ListObjects("TableC").TableStyle = "TableStyleLight11"
'念のため、列幅を再設定
For i = 1 To UBound(cWidth)
If cWidth(i) > oneDW Then
myCW = (cWidth(i) - mgnWidth) / bstrWidth
Else
myCW = cWidth(i) / oneDW
End If
.Columns(i).ColumnWidth = myCW
Next i
Call MakeButtons2
.Cells(1, 1).Select
End With
Call Updating
End Sub
'+++*****************************************************+++
' ワークシート比較ツール【比較結果】シート
' ボタンを作成
'+++*****************************************************+++
Public Sub MakeButtons2()
Dim nameArray As Variant
Dim textArray As Variant
Dim macroArray As Variant
Dim pstnArray As Variant
Dim myPosi As Variant
Dim myBtn As Object
Dim i As Long
Dim myShp As Shape
nameArray = Array("", "保存2", "開く 2", "保存1", "開く 1", _
"自動計算")
textArray = Array("", "変更を保存して閉じる", _
"読み取り 手動計算で開く", "変更を保存して閉じる", _
"読み取り 手動計算で開く", "自 動 計 算")
macroArray = Array("", "exeSaveClose", "openFile", _
"exeSaveClose", "openFile", "AutoCalc")
pstnArray = Array("0,0,0,0", "831.5,92.5,103,27,27", _
"719.5,92.5,103,27,27", "831.5,58,103,27,27", _
"719.5,58,103,27,27", "962.283,4,103.5,27.5,27.5")
With ActiveSheet
For i = 1 To UBound(nameArray)
myPosi = Split(pstnArray(i), ",")
Set myBtn = .Buttons.Add(myPosi(0), _
myPosi(1), _
myPosi(2), _
myPosi(3))
With myBtn
.Name = nameArray(i)
.Font.Name = "Meiryo UI" '文字のサイズ
With .Characters 'テキスト
.Text = textArray(i) '文字列
.Font.Size = 9 '文字のサイズ
End With
.OnAction = macroArray(i)
End With
Next i
Set myShp = .Shapes.AddTextbox(msoTextOrientationHorizontal, _
941.6, 41.5, 124, 86.43)
With myShp
With .TextFrame2.TextRange.Font
.Size = 10 '文字のサイズ
.NameComplexScript = "Meiryo UI" '文字のフォント
.NameFarEast = "Meiryo UI"
.Name = "Meiryo UI"
End With
.TextFrame2.TextRange.Characters.Text = _
"コピーされたデータシートの" & vbLf & _
"マクロ付きボタンや、値の入っていないセルは、処理とファイルを軽くするために消去しています。 "
With .TextFrame
' テキストを図形からはみ出して表示する
.HorizontalOverflow = Excel.XlOartHorizontalOverflow.xlOartHorizontalOverflowOverflow
.VerticalOverflow = Excel.XlOartVerticalOverflow.xlOartVerticalOverflowOverflow
End With
With .Fill
.Visible = msoTrue
.ForeColor.RGB = 16247773
.Transparency = 0
.Solid
End With
End With
End With
End Sub
コメント