VBAワールドの検討
現在マイナーなところを調査しているんですがサグラダファミリアなみの絵図をまず書いてから、それを埋めていこうかなと思い立ちました。
- 1.VBAの事始め-チュートリアル
- 2.VBAでの開発時に行うデバグとテスト方法について
- 3.VBAの小技、部品集とサンプルプログラム
- 4.VBAの高速化に関する知識について
- 5.VBEのソースコードに対するロックのやり方と解除の仕方
- 6.エクセルマクロアプリケーションのバージョンアップの自動化
- 7.試してよかった世の中にあるツールなど
まずはアトランダムに思いついたキーワード等を羅列してみます。
- VBAの事始め-チュートリアル
- VBAでの開発時に行うデバグとテスト方法について
- VBAの小技、部品集とサンプルプログラム
- VBAの高速化に関する知識について
- VBEのソースコードに対するロックのやり方と解除の仕方
- エクセルマクロアプリケーションのバージョンアップの自動化
- 試してよかった世の中にあるツールなど
1.VBAの事始め-チュートリアル
2.VBAでの開発時に行うデバグとテスト方法について
3.VBAの小技、部品集とサンプルプログラム
これをちょっとダウンロードして解除できるか試してみる。
4.VBAの高速化に関する知識について
5.VBEのソースコードに対するロックのやり方と解除の仕方
6.エクセルマクロアプリケーションのバージョンアップの自動化
7.試してよかった世の中にあるツールなど
はてなブログ ソースコードの表示について その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.(方式変更)比較が遅いのはセル比較をしているからである。これを配列の比較で実施すると劇的に早くなる。
【改造実施中】
早速実施してみました。
一応うまくいきました!
予測時間が新仕様での計算になってなかったのでこれから修正します。
なおここで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 '■比較対象シートの範囲を配列に格納する '比較シート、比較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