VBA 素晴らしいアドインソフトをいじってみた！

最近とても素晴らしいアドインソフトに出会った・・・

RelaxTools

機能豊富で操作性にも優れていると思いました。

IT開発等に従事する方でマニュアルや設計書を作成するケースやレビューを記録する場合でも役に立ちそうですね。

その中で「チェック」➡「シート同士の比較（セル単位）」を実行すると・・・

シート比較

比較対象シートを選択するダイアログが出てきます。

シート比較ダイアログ

比較ボタンを押下すると比較結果シートが作成されます。

比較結果シート

この機能は比較対象セル数が１万セル(1000行x10カラム）ぐらいまでなら比較処理自体は5秒ぐらいで終わりそうです。（相違件数：10件以内を想定）

ですが10万セル(1000行x100カラム）だとどうなるでしょうか？

単純比例の場合は50秒です。これぐらいならまだ待てそうですね。

ところが100万セル(10000行x100カラム）だと500秒かかります。

これはちょっとその間他の作業ができなくなりますので勘弁してほしいとなります。

【結論】ドキュメントの比較にとどめておいた方がよい気がします。SQLのセレクト文の結果シートの比較とかやると恐ろしく時間がかかりそうです。

【ところで！】MITライセンスのアドインツールなので自分で改造すればいい話になります。なぜこんなことを言い出すかというと私は自力でシート比較ツールを作成したのです。次は何を作ろうかと思案していたのですが偶然この素晴らしいアドインソフトに出会ったわけです。そして私が作った比較ツールは手前味噌ですがこのアドインソフトより高性能で比較をすることができていたのです。だからこのシート比較機能も私が改造すれば早くなりそうだという見通しの中で改造仕様を考えてみました。

【問題点】

１．比較セル処理の性能(2000件/秒)程度であるため2万セルまでしか快適に使えない。

２．不一致のリンク処理が比較処理の2倍はかかると予想される。

３．比較シートに背景色をつける作業もコストがかかりそう。

【解決案】

１．（運用面）実行前に処理件数が2万件を超えた場合は処理予測時間を表示して実行するか問い合わせる

２．（運用面）実行時に不一致の件数が100件を超えたらそれ以上はリストアップするのをやめる

３．（運用面）比較シートに背景色をつける作業も同様に処置する

４．（方式変更）比較が遅いのはセル比較をしているからである。これを配列の比較で実施すると劇的に早くなる。

【改造実施中】

早速実施してみました。 

一応うまくいきました！

予測時間が新仕様での計算になってなかったのでこれから修正します。

なおここでOKボタンをクリック後3秒ほどだんまりがあって比較結果シートの完成となります。

（相違箇所の100件の書式調整等の作成にかかっているものと予想）

今日はここまで！

おまけ！

私の自作のシート比較ツールです。

高速化したシート比較のvbaソースコード



'-----------------------------------------------------------------------------------------------------
'
' [RelaxTools-Addin] v4
'
' Copyright (c) 2009 Yasuhiro Watanabe
' https://github.com/RelaxTools/RelaxTools-Addin
' author:relaxtools@opensquare.net
'
' The MIT License (MIT)
'
' Permission is hereby granted, free of charge, to any person obtaining a copy
' of this software and associated documentation files (the "Software"), to deal
' in the Software without restriction, including without limitation the rights
' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
' copies of the Software, and to permit persons to whom the Software is
' furnished to do so, subject to the following conditions:
'
' The above copyright notice and this permission notice shall be included in all
' copies or substantial portions of the Software.
'
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
' SOFTWARE.
'
'-----------------------------------------------------------------------------------------------------

Option Explicit
Private mblnCancel As Boolean
Private Const C_START_ROW As Long = 8

Private Const C_COMP_NO As Long = 1
Private Const C_COMP_RESULT As Long = 2
Private Const C_COMP_SRCSTR As Long = 3
Private Const C_COMP_DSTSTR As Long = 4
Private Const C_COMP_BOOK As Long = 5
Private Const C_COMP_SHEET As Long = 6
Private Const C_COMP_ADDRESS As Long = 7

Private Sub cboDstBook_Change()
Dim s As Worksheet

cboDstSheet.Clear
If cboDstBook.ListIndex <> -1 Then
For Each s In Workbooks(cboDstBook.Text).Worksheets
cboDstSheet.AddItem s.Name
Next
End If
End Sub

Private Sub cboSrcBook_Change()
Dim s As Worksheet

cboSrcSheet.Clear
If cboSrcBook.ListIndex <> -1 Then
For Each s In Workbooks(cboSrcBook.Text).Worksheets
cboSrcSheet.AddItem s.Name
Next
End If
End Sub

Private Sub cmdCancel_Click()
If cmdCancel.Caption = "閉じる" Then
Unload Me
Else
mblnCancel = True
End If
End Sub

'Private Sub cmdOk_Click()
'
' Dim srcSheet As Worksheet
' Dim dstSheet As Worksheet
'
' If cboSrcSheet.ListIndex = -1 Then
' MsgBox "比較元のシートを入力してください。", vbOKOnly + vbExclamation, C_TITLE
' Exit Sub
' End If
' If cboDstSheet.ListIndex = -1 Then
' MsgBox "比較先のシートを入力してください。", vbOKOnly + vbExclamation, C_TITLE
' Exit Sub
' End If
'
' Set srcSheet = Workbooks(cboSrcBook.Text).Worksheets(cboSrcSheet.Text)
' Set dstSheet = Workbooks(cboDstBook.Text).Worksheets(cboDstSheet.Text)
'
' Dim srcBook As Workbook
' Dim dstBook As Workbook
'
' Dim r1 As Range
' Dim d1 As Variant
' Dim r2 As Range
' Dim d2 As Variant
'
' Dim i As Long
' Dim j As Long
' Dim lngCount As Long
'
' Dim strSrcAddress As String
' Dim strDstAddress As String
'
' Set srcBook = srcSheet.Parent
' Set dstBook = dstSheet.Parent
'
' strSrcAddress = srcSheet.UsedRange.Address
' strDstAddress = dstSheet.UsedRange.Address
'
' Set r1 = Union(dstSheet.Range(strSrcAddress), dstSheet.Range(strDstAddress))
' d1 = r1
'
' Set r2 = Union(srcSheet.Range(strSrcAddress), srcSheet.Range(strDstAddress))
' d2 = r2
'
'
'
' Dim ResultWS As Worksheet
' ThisWorkbook.Worksheets("比較結果").Copy
' Set ResultWS = ActiveSheet
'
' ResultWS.Name = "比較結果"
'
' ResultWS.Cells(1, C_COMP_NO).Value = "シートの比較"
' ResultWS.Cells(2, C_COMP_NO).Value = "比較元：" & cboSrcBook.Text & "!" & cboSrcSheet.Text
' ResultWS.Cells(3, C_COMP_NO).Value = "比較先：" & cboDstBook.Text & "!" & cboDstSheet.Text
' ResultWS.Cells(4, C_COMP_NO).Value = "不一致の比較元の背景色を変更する（黄）：" & chkSrcColor.Value
' ResultWS.Cells(5, C_COMP_NO).Value = "不一致の比較先の背景色を変更する（赤）：" & chkDstColor.Value
'
' ResultWS.Cells(7, C_COMP_NO).Value = "No."
' ResultWS.Cells(7, C_COMP_RESULT).Value = "結果"
' ResultWS.Cells(7, C_COMP_SRCSTR).Value = "比較元文字列"
' ResultWS.Cells(7, C_COMP_DSTSTR).Value = "比較先文字列"
' ResultWS.Cells(7, C_COMP_BOOK).Value = "比較先ブック"
' ResultWS.Cells(7, C_COMP_SHEET).Value = "比較先シート"
' ResultWS.Cells(7, C_COMP_ADDRESS).Value = "アドレス"
' lngCount = C_START_ROW
'
' If IsEmpty(d1) Or IsEmpty(d2) Then
' GoTo e
' End If
'
' Dim mm As MacroManager
' Set mm = New MacroManager
' Set mm.Form = Me
' mm.Disable
' mm.DispGuidance "セル数をカウントしています..."
'
' mm.StartGauge (UBound(d1, 1) - LBound(d1, 1) + 1) * (UBound(d1, 2) - LBound(d1, 2) + 1)
' Dim lngCnt As Long
' lngCnt = 0
'
' For i = LBound(d1, 1) To UBound(d1, 1)
' For j = LBound(d1, 2) To UBound(d1, 2)
' If mblnCancel Then
' GoTo e
' End If
' If d1(i, j) <> d2(i, j) Then
' makeResult ResultWS, srcSheet, dstSheet, lngCount, i, j
'
' Else
' '空セル対策
' If IsEmpty(d1(i, j)) <> IsEmpty(d2(i, j)) Then
' makeResult ResultWS, srcSheet, dstSheet, lngCount, i, j
' End If
' End If
' lngCnt = lngCnt + 1
' mm.DisplayGauge lngCnt
' Next
' Next
'
'
' ResultWS.Columns("B:G").AutoFit
' Dim r As Range
' Set r = ResultWS.Cells(C_START_ROW, 1).CurrentRegion
'
' r.VerticalAlignment = xlTop
' r.Select
'
' execSelectionRowDrawGrid
'e:
' Set ResultWS = Nothing
' Unload Me
'
'End Sub

'Sub makeResult(ByRef ResultWS As Worksheet, ByRef srcSheet As Worksheet, ByRef dstSheet As Worksheet, ByRef lngCount As Long, ByVal i As Long, ByVal j As Long)
'
' ResultWS.Cells(lngCount, C_COMP_NO).Value = lngCount - C_START_ROW + 1
' ResultWS.Cells(lngCount, C_COMP_RESULT).Value = "不一致"
' ResultWS.Cells(lngCount, C_COMP_BOOK).Value = dstSheet.Parent.Name
' ResultWS.Cells(lngCount, C_COMP_SHEET).Value = dstSheet.Name
' ResultWS.Cells(lngCount, C_COMP_ADDRESS).Value = dstSheet.Cells(i, j).Address
' ResultWS.Cells(lngCount, C_COMP_SRCSTR).Value = srcSheet.Cells(i, j).Value
' ResultWS.Cells(lngCount, C_COMP_DSTSTR).Value = dstSheet.Cells(i, j).Value
'
' ResultWS.Hyperlinks.Add _
' Anchor:=ResultWS.Cells(lngCount, C_COMP_ADDRESS), _
' Address:="", _
' SubAddress:=ResultWS.Cells(lngCount, C_COMP_ADDRESS).Address, _
' TextToDisplay:=dstSheet.Cells(i, j).Address
'
' On Error Resume Next
' If chkSrcColor Then
' srcSheet.Cells(i, j).Interior.Color = vbYellow
' End If
' If chkDstColor Then
' dstSheet.Cells(i, j).Interior.Color = vbRed
' End If
'
' lngCount = lngCount + 1
'
'End Sub

Private Sub UserForm_Initialize()

Dim b As Workbook

For Each b In Workbooks
cboSrcBook.AddItem b.Name
cboDstBook.AddItem b.Name
Next

'--------------------------------------------
cboSrcSheet.Clear
cboDstSheet.Clear
'--------------------------------------------
chkSrcColor.Value = True
chkDstColor.Value = True

lblGauge.visible = False
mblnCancel = False

End Sub


Private Sub cmdOk_Click()
Dim CurLineMsg, msg As String
Dim srcSheet As Worksheet
Dim dstSheet As Worksheet

If cboSrcSheet.ListIndex = -1 Then
MsgBox "比較元のシートを入力してください。", vbOKOnly + vbExclamation, C_TITLE
Exit Sub
End If
If cboDstSheet.ListIndex = -1 Then
MsgBox "比較先のシートを入力してください。", vbOKOnly + vbExclamation, C_TITLE
Exit Sub
End If

If cboSrcBook.Text = cboDstBook.Text And cboSrcSheet.Text = cboDstSheet.Text Then
MsgBox "比較元と比較先が同じです。", vbOKOnly + vbExclamation, C_TITLE
Exit Sub
End If

Set srcSheet = Workbooks(cboSrcBook.Text).Worksheets(cboSrcSheet.Text)
Set dstSheet = Workbooks(cboDstBook.Text).Worksheets(cboDstSheet.Text)

Dim srcBook As Workbook
Dim dstBook As Workbook

Dim r1 As Range
Dim r2 As Range

Dim i As Long
Dim j As Long
Dim lngCount As Long

Dim strSrcAddress As String
Dim strDstAddress As String

Set srcBook = srcSheet.Parent
Set dstBook = dstSheet.Parent

strSrcAddress = srcSheet.UsedRange.Address
strDstAddress = dstSheet.UsedRange.Address

' Set r1 = Union(dstSheet.Range(strSrcAddress), dstSheet.Range(strDstAddress))
' Set r2 = Union(srcSheet.Range(strSrcAddress), srcSheet.Range(strDstAddress))
Set r1 = Union(srcSheet.Range(strSrcAddress), srcSheet.Range(strDstAddress))
Set r2 = Union(dstSheet.Range(strSrcAddress), dstSheet.Range(strDstAddress))


Dim ResultWS As Worksheet
ThisWorkbook.Worksheets("比較結果").Copy
Set ResultWS = Application.Workbooks(Application.Workbooks.Count).Worksheets(1)

ResultWS.Name = "比較結果"

ResultWS.Cells(1, C_COMP_NO).Value = "シートの比較"
ResultWS.Cells(2, C_COMP_NO).Value = "比較元：" & cboSrcBook.Text & "!" & cboSrcSheet.Text
ResultWS.Cells(3, C_COMP_NO).Value = "比較先：" & cboDstBook.Text & "!" & cboDstSheet.Text
ResultWS.Cells(4, C_COMP_NO).Value = "不一致の比較「元」の背景色を変更する（黄）：" & chkSrcColor.Value
ResultWS.Cells(5, C_COMP_NO).Value = "不一致の比較「先」の背景色を変更する（赤）：" & chkDstColor.Value

ResultWS.Cells(7, C_COMP_NO).Value = "No."
ResultWS.Cells(7, C_COMP_RESULT).Value = "結果"
ResultWS.Cells(7, C_COMP_SRCSTR).Value = "比較元文字列"
ResultWS.Cells(7, C_COMP_DSTSTR).Value = "比較先文字列"
ResultWS.Cells(7, C_COMP_BOOK).Value = "比較先ブック"
ResultWS.Cells(7, C_COMP_SHEET).Value = "比較先シート"
ResultWS.Cells(7, C_COMP_ADDRESS).Value = "アドレス"
lngCount = C_START_ROW

If r1 Is Nothing Or r2 Is Nothing Then
GoTo e
End If

Dim mm As MacroManager
Set mm = New MacroManager
Set mm.Form = Me

mm.Disable
mm.DispGuidance "セル数をカウントしています..."

mm.StartGauge r1.Count

Dim s1timer, s2timer As Double
Dim Timer_s1s2 As String
Dim rc As Long
Dim qRunOk As String
Dim pCnt As Long

msg = "実行してもよいですか？" & vbCrLf & "なお比較相違箇所は100件までしかリストアップしません！" & vbCrLf & _
"比較ｾﾙ数：" & Format(r1.Count, "###,###") & "件" & vbCrLf & "予測時間：" & r1.Count / 2000000 & "秒"

rc = MsgBox(msg, vbOKCancel, C_TITLE & "[ cmdOk_Click():L337 ]")
If rc = vbCancel Then
Exit Sub
End If

s1timer = Timer
pCnt = 0

'■比較対象シートの範囲を配列に格納する
'比較シート、比較１シート、比較２シートの値を配列としてセットする。理由：配列比較を実施すると性能が100倍アップする。
Dim ar1 As Variant
Dim ar2 As Variant
Dim last_col, last_row As Long
'Dim ar3 As Variant
last_col = r1.Columns.Count
last_row = r1.Rows.Count

ar1 = srcSheet.Range(srcSheet.Cells(1, 1), srcSheet.Cells(last_row, last_col))
ar2 = dstSheet.Range(dstSheet.Cells(1, 1), dstSheet.Cells(last_row, last_col))
'ar3 = ResultWS.Range(ResultWS.Cells(1, 1), ResultWS.Cells(last_row * 2 + 7, last_col + 1))

'配列でない場合があるのでそれをチェックする。例えばRangeが１セルのみの場合は配列にならない。
Select Case IsArrayEx(ar1)
Case 1 '配列
'なにもしない
Case 0 '空配列
'なにもしない
Case -1 'Not配列
ReDim ar1(last_row, last_col)
ar1(last_row, last_col) = srcSheet.Range(srcSheet.Cells(1, 1), srcSheet.Cells(last_row, last_col))
End Select

Select Case IsArrayEx(ar2)
Case 1 '配列
'なにもしない
Case 0 '空配列
'なにもしない
Case -1 'Not配列
ReDim ar2(last_row, last_col)
ar2(last_row, last_col) = dstSheet.Range(dstSheet.Cells(1, 1), dstSheet.Cells(last_row, last_col))
End Select

'ar3row = 8 '比較不一致の開始行番号
Dim diff_cnt, disp_cnt, skip_cnt, total_cnt As Long
Dim disp_flag, hit_flag As Boolean

diff_cnt = 0 '相違セルの件数
disp_cnt = 0 '相違行数
skip_cnt = 100 '相違チェック停止件数
disp_flag = True
hit_flag = False

For i = 1 To last_row
　For j = 1 To last_col
　　total_cnt = total_cnt + 1
　　If (ar1(i, j) <> ar2(i, j)) Then
　　　If disp_flag Then
　　　　makeResult ResultWS, srcSheet, dstSheet, lngCount, r1(total_cnt), r2(total_cnt)
　　　End If

　　　diff_cnt = diff_cnt + 1
　　　If diff_cnt = skip_cnt And diff_cnt <> 0 Then
　　　　disp_flag = False
　　　End If
　　End If
　Next
Next
' For i = 1 To r1.Count
'
' If mblnCancel Then
' GoTo e
' End If
'
' If IsError(r1(i).Value) Or IsError(r2(i).Value) Then
' pCnt = pCnt + 1
' If pCnt < 101 Then
' makeResult ResultWS, srcSheet, dstSheet, lngCount, r1(i), r2(i)
' End If
' Else
' '空セル対策
' If IsEmpty(r1(i).Value) And IsEmpty(r2(i).Value) Then
' Else
' If r1(i).Value <> r2(i).Value Then
' pCnt = pCnt + 1
' If pCnt < 101 Then
' makeResult ResultWS, srcSheet, dstSheet, lngCount, r1(i), r2(i)
' End If
' End If
' End If
' End If
'
' mm.DisplayGauge i
'
' Next
s2timer = Timer
Timer_s1s2 = Application.RoundDown(s2timer - s1timer, 3) & "00000"
Timer_s1s2 = "処理時間：" & Left(Timer_s1s2, InStr(Timer_s1s2, ".")) & Mid(Timer_s1s2, InStr(Timer_s1s2, ".") + 1, 3) & "秒"

MsgBox "比較ｾﾙ数：" & Format(r1.Count, "###,###") & vbCrLf & Timer_s1s2 & vbCrLf & "相違件数：" & Format(diff_cnt, "###,###"), vbOKOnly, C_TITLE & "[ cmdOk_Click():L445 ]"

ResultWS.Columns("B:G").AutoFit
ResultWS.Select

Dim r As Range
Set r = ResultWS.Cells(C_START_ROW, 1).CurrentRegion

r.VerticalAlignment = xlTop
r.Select
execSelectionRowDrawGrid

ResultWS.Parent.Activate
ResultWS.Range("G7").Select

e:
Unload Me

ResultWS.Parent.Activate
ResultWS.Range("G7").Select
Set ResultWS = Nothing

End Sub
Sub makeResult(ByRef ResultWS As Worksheet, ByRef srcSheet As Worksheet, ByRef dstSheet As Worksheet, ByRef lngCount As Long, ByRef r1 As Range, ByRef r2 As Range)

ResultWS.Cells(lngCount, C_COMP_NO).Value = lngCount - C_START_ROW + 1
ResultWS.Cells(lngCount, C_COMP_RESULT).Value = "不一致"
ResultWS.Cells(lngCount, C_COMP_BOOK).Value = dstSheet.Parent.Name
ResultWS.Cells(lngCount, C_COMP_SHEET).Value = dstSheet.Name
ResultWS.Cells(lngCount, C_COMP_ADDRESS).Value = r1.Address
ResultWS.Cells(lngCount, C_COMP_SRCSTR).Value = r1.Value
ResultWS.Cells(lngCount, C_COMP_DSTSTR).Value = r2.Value

ResultWS.Hyperlinks.Add _
Anchor:=ResultWS.Cells(lngCount, C_COMP_ADDRESS), _
Address:="", _
SubAddress:=ResultWS.Cells(lngCount, C_COMP_ADDRESS).Address, _
TextToDisplay:=r1.Address

On Error Resume Next
If chkSrcColor Then
r1.Interior.Color = vbYellow
End If
If chkDstColor Then
r2.Interior.Color = vbRed
End If

lngCount = lngCount + 1

End Sub

Module1に関数を定義しておく

'***********************************************************
'■構文 IsArrayEx(varname)
'■機能 引数が配列かどうかを判定し､配列であった場合は空かどうかも判定します｡
'■引数
'       引数    省略    説明
'       varname 不可    有効な任意の式を指定します。
'■戻り値
'       長整数型（Long）
'
'戻り値 説明
'1      配列
'0      空の配列
'-1     配列じゃない
'***********************************************************
' 機能   : 引数が配列か判定し、配列の場合は空かどうかも判定する
' 引数   : varArray  配列
' 戻り値 : 判定結果（1:配列/0:空の配列/-1:配列じゃない）
'***********************************************************
Public Function IsArrayEx(varArray As Variant) As Long
On Error GoTo ERROR_

    If IsArray(varArray) Then
        IsArrayEx = IIf(UBound(varArray) >= 0, 1, 0)
    Else
        IsArrayEx = -1
    End If

    Exit Function

ERROR_:
    If Err.Number = 9 Then
        IsArrayEx = 0
    End If
End Function