VBAワールドの検討

現在マイナーなところを調査しているんですがサグラダファミリアなみの絵図をまず書いてから、それを埋めていこうかなと思い立ちました。

www.nta.co.jp

まずはアトランダムに思いついたキーワード等を羅列してみます。

  1. VBAの事始め-チュートリアル
  2. VBAでの開発時に行うデバグとテスト方法について
  3. VBAの小技、部品集とサンプルプログラム
  4. VBAの高速化に関する知識について
  5. VBEのソースコードに対するロックのやり方と解除の仕方
  6. エクセルマクロアプリケーションのバージョンアップの自動化
  7. 試してよかった世の中にあるツールなど

1.VBAの事始め-チュートリアル

news.mynavi.jp

news.mynavi.jp

matome.naver.jp

2.VBAでの開発時に行うデバグとテスト方法について

www.asahi-net.or.jp

qiita.com

www.atmarkit.co.jp

www.sejuku.net

www.buildinsider.net

www.ken3.org

www.techmatrix.co.jp


tonari-it.com

asatte.biz

3.VBAの小技、部品集とサンプルプログラム

excelkamiwaza.com

officeboole-vba.fan.coocan.jp

hp.vector.co.jp

pckowaza.web.fc2.com

excel-magic.com

www.ebisawa.co.jp

 これをちょっとダウンロードして解除できるか試してみる。

soft.rifnet.or.jp

4.VBAの高速化に関する知識について

 

5.VBEのソースコードに対するロックのやり方と解除の仕方

 

6.エクセルマクロアプリケーションのバージョンアップの自動化

 

7.試してよかった世の中にあるツールなど

 

 

VBA 今後の調査予定について

VBAについて現時点の構想は以下の通りです。
・備忘録として
 EXCELのワークシート関数の中でトリッキーなものについてピックアップする
 EXCELの関数では相当面倒な記述を要するものをユーザ定義関数で使うようにする
 VBAの自作の関数一覧と使用例のサンプルブックの充実化
・調査・作成予定のもの
 EXCELブックで作成されたアプリケーションのバージョンアップが生じていないかを立ち上げ時にチェックする機能
 EXCELアプリのバージョンアップや戻しが簡単に行えるようにする方法
 プロジェクトのロック関連の作成・解除の手引き
 メール分析、自動返信、時間指定送信など
 

 

はてなブログ ソースコードの表示について その2

昨日から四苦八苦して漸くソースコードをブログ記事中に張り付ける方法が確立したような気がします。とりあえずこの程度で調査を打ち切ろうかなと思っています。
【こういう現象がでても気にしないでください!】
ブログ表示においてノベタンで表示する場合はちゃんとJavaScriptが効いているのにブログを1ページずつ表示する方式では効いてないみたいです。
原因がよくわからない。最終的にはHTMLのコードで書いてやらないと「はてな風記法」ではうまくいかないケースがあるのかもしれません・・・
【理由は編集直後のJavaScriptの実行が追い付かないケースがあるみたいです】
二転三転して申し訳ないがどうも更新直後に表示させるとだめみたいだ!

1.フッターに張り付けたJavaScriptソースコード

<script>
let codes = document.getElementsByClassName('code');
[].forEach.call(codes, function(elem, key, val){
    // クラスに lang が含まれていない場合は何もしない
    if (!/lang/.test(elem.className)) {
        return;
    }
    let line_num = 1;
    // 行で分割
    let lines = elem.innerHTML.split("\n");
    let texts = elem.textContent.split("\n");
    // 最終行が空の時は削除
    if (lines[lines.length-1].length === 0) {
        lines.pop();
    }
    // 最初の1行目にコメント後の数字:か、数字:があれば、先頭の行番号にする(2017/4/15修正)
    if ((texts.length > 0) && (/(^|\/\/|\/\*) *[0-9]+:/.test(texts[0].trim()))) {
        line_num = texts[0].trim().replace(/:/, "").replace(/(\/\/|\/\*)/, "")-0;
        lines.shift();
    }
    let modi = "<ol start='"+line_num+"'>";
    lines.forEach(function(elem) {
        modi += "<li class='code-list'>"+elem+"</li>";
    });
    modi += "</ol>";
    elem.innerHTML = modi;
});
</script>
<script defer>
;(function(d){

if(!window.getSelection){
  return
}

var btn = d.createElement("button")
btn.id = "selectPre"
btn.textContent = "select"
btn.addEventListener("click", selectPre, false)

function selectPre(){
  var sel = window.getSelection()
  var pre = this.parentNode
  sel.selectAllChildren(pre)
  sel.extend(pre, pre.childNodes.length-1)
}


var pres = d.getElementsByTagName("pre")
for(var i=pres.length; i--;){
  pres[i].addEventListener("mouseover", addBtn, false)
}

function addBtn(e){
  if(this === addBtn.ele) return // not to addBtn if already
  this.appendChild(btn)
  return addBtn.ele = this
}

})(document)
</script>
<script type="text/javascript">
window.addEventListener("load", function onLoad() {
  window.removeEventListener("load", onLoad);
  var codes = document.querySelectorAll("pre.code");
  var len = codes.length;
  for (var i = 0; i < len; i++) {
    (function () {
      var code = codes[i];
      // select all on double click
      code.addEventListener("dblclick", function () {
        var range = document.createRange();
        range.selectNodeContents(code);
        var selection = document.getSelection();
        selection.removeAllRanges();
        selection.addRange(range);
      });
    })();
  }
});
</script>

2.CSSに張り付けたソースコード

/* <system section="theme" selected="6653586347155924442"> */
@import url("https://blog.hatena.ne.jp/-/theme/6653586347155924442.css");
/* </system> */

/*code-listクラスの数でカウント*/
.code-list:nth-child(2n+1) {
    background-color: #eee;
}
#selectPre{
  position: absolute;
  top: 0;
  right: 0;
  border: none;
  padding: 2px 3px;
  font-family: consolas
}
/*code-lineクラスの数でカウント*/
.code-line {
  counter-increment: linenumber;
}
/*偶数行のみ背景色を適用*/
.code-line:nth-child(even){
  background-color: #eee;
}
/*行番号を擬似要素として表示*/
.code-line::before {
  content: counter(linenumber);
  display:inline-block;
  color: #ccc;
  text-align: right;
  width: 35px;
  padding: 0 15px 0 0;
}
/*コードブロックに言語名を表示*/
pre.code:before {
    content: attr(data-lang);
    display: inline-block;
    background: #ccc; /*カラーコード変更*/
    color: #666;
    padding: 5px;
    position: absolute;
    margin-left: -20px; /*表示位置を調整*/
    margin-top: -30px;
}
pre.code {
    padding-top: 30px !important;
    border:2px solid #ccc; /*追加:コード表示部分の枠設定*/
    background:#f8f8f8; /*追加:コード表示部分の背景色*/
    position:relative; /*追加*/
}
*グローバルメニュー*/
 #global-menu {
 background-color: #444444; /*ナビメニューの両サイド背景の色変更*/
 border-bottom: 2px solid #444444; /*ナビメニュー下部のラインカラー変更*/
 }
 .global-menu-list li a {
 color: #fff; /*ナビメニューの文字色変更*/
 background-color: #444444; /*ナビメニューの背景色変更*/
 }
 #mobile-head {
 background-color: #444444; /*スマホ版 ナビメニューの背景色変更*/
 }
 #blog-title {
  border-bottom: 1px solid #444444; /*ナビメニュー上部のラインカラー変更*/
 }

3.ヘッダーに貼り付けたソースコード

<link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/font-awesome/4.4.0/css/font-awesome.min.css">
<div id="global-menu">
<ul class="global-menu-list">
<li><a href="https://www.notitle-weblog.com/entry/2016/02/04/171538" target="_blank">Webデザイン</a></li>
<li><a href="ここにリンク先のアドレス">ここにメニューの名前</a></li>
<li><a href="ここにリンク先のアドレス">ここにメニューの名前</a></li>
<li><a href="ここにリンク先のアドレス">ここにメニューの名前</a></li>
<li><a href="ここにリンク先のアドレス">ここにメニューの名前</a></li>
</ul>
</div>

はてなブログ ソースコードの表示について

今回初めてソースコードをブログ上で表示しようとして色々サイトをぐぐって調べやり方はわかったが実際には思ったように動いてくれないので困っている。Webブラウザ上でのデバグの仕方を身に着けてないのでどこがおかしいのかわからないでお手上げ状態である。

これまでに得た知識の整理:

1.HTML上の記述方法
 ソースコードをHTMLの中で表示したい場合は、
<pre><code> </code></pre>

で挟んだ中にソースコードを記述すると以下の恩恵が得られるらしい。
等幅フォントで表現される。➡ なぜか罫線とかはダメでした。
・改行を見た目のまま実現してくれる。
・<pre>タグを使うと、改行やタブ・スペースを入れて整形したテキストをそのまま表示することができます。<pre>は「preformatted text」の略です。

2.はてなブログにおけるソースコードを埋め込むやり方
 3つあるらしいがそのうちの一つであるはてなブログの記述でやってみたが結果が期待どおりにならなかった。
>|java|
String peace = "azatoi";
||<

 具体的にここまででこの記事がHTML的にどのようになっているかこれからチェックします。

3.HTML編集モードがでない・・・
 調べたら最初に編集モードが「はてな記法」になっているとHTMLタブは出ないみたいです。
 よってこの記事はHTMLタブが出ない状態となっています。
 別途もう一回記事を書く前に編集モードを「みたまま」とかにしてからここの本文を再度記述して確認してみたいと思います。

4.はてな記法ソースコードを表示する方法は下記のようにうまくいったようです。
  ただ行番号がだめみたいですね。➡原因がわかりました。実現方法については別記事にて説明します。

String peace = "azatoi";

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

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

RelaxTools

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

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

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

シート比較

シート比較

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

シート比較ダイアログ

シート比較ダイアログ

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

比較結果シート

比較結果シート

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

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

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

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

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

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

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

【問題点】

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

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

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

【解決案】

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

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

3.(運用面)比較シートに背景色をつける作業も同様に処置する

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

【改造実施中】

早速実施してみました。 

f:id:gyokusen_since:20190110160151p:plain

f:id:gyokusen_since:20190110161442p:plain

f:id:gyokusen_since:20190110161513p:plain

f:id:gyokusen_since:20190110161653p:plain

一応うまくいきました!

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

f:id:gyokusen_since:20190110162623p:plain

f:id:gyokusen_since:20190110162651p:plain

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

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

今日はここまで!

おまけ!

f:id:gyokusen_since:20190110164420p:plain

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

高速化したシート比較の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

'■比較対象シートの範囲を配列に格納する
'比較シート、比較1シート、比較2シートの値を配列としてセットする。理由:配列比較を実施すると性能が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が1セルのみの場合は配列にならない。
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