【VBA】Excelはアクティブシートが変わると、処理時間が変わる場合があるようだ
いつもの如く、怪しげな事(?)をゴニョゴニョとやっていて、
「あれ、さっきより処理速くね?」となったので・・・
経緯
ワークシートに50万件ほどのデータがあって、そいつにフィルターを掛けて外しての繰り返しをやっていたら、何かの拍子に処理時間が早くなったんですよ。
調べてみたら、フィルター処理を行う時に、
フィルターを適用するワークシートをアクティブにしているより、
フィルターを適用しないワークシートをアクティブにしておいた方が
速かったんですよ。
もちろん
With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With
は適用した上ですよ。
ブックには、式が1つもないので、下2つは、ほとんど意味がないような気がするけど、お約束なので・・・
結果
とりあえず、というか、いきなり結果から。
速度順に並べたが、「フィルターを適用するシート以外のシート」をアクティブにしたケースが全て上位になっている。率にして、15%以上の差が出ており、誤差と言える値ではなさそうである。
「平均処理時間」は、5回実行した結果の平均値。
アクティブシート | ScreenUpdating | WindowState | 平均処理時間(秒) | 備 考 |
非フィルター適用シート | False | xlMinimized | 16.31 | |
非フィルター適用シート | False | xlNormal | 16.32 | Worksheet.Visible = False |
非フィルター適用シート | False | xlNormal | 16.35 | |
非フィルター適用シート | True | xlMinimized | 16.46 | |
非フィルター適用シート | True | xlNormal | 16.65 | Worksheet.Visible = False |
非フィルター適用シート | True | xlNormal | 16.67 | |
フィルター適用シート | False | xlNormal | 18.85 | |
フィルター適用シート | False | xlMinimized | 18.86 | |
フィルター適用シート | True | xlMinimized | 21.04 | |
フィルター適用シート | True | xlNormal | 25.13 |
コード
Private Const KEY_COL As Long = 1 Private Const DATA_SHEET_NAME As String = "Data" Private Const KEY_SHEET_NAME As String = "Key" Private Const HEADER_ROWS As Long = 1 Private Const MAX_KEYS_COUNTS As Long = 50 Private Const MAX_DATAS_COUNTS As Long = 500000 Public Sub queryByAutoFilter() Dim ws As Worksheet Dim r As Range Dim lEndRow As Long Dim sgStart As Single Dim sgStop As Single Dim vKeys() As Variant Dim i As Long Dim lMatchCount As Long With Application .ScreenUpdating = False ' .ScreenUpdating = True .EnableEvents = False .Calculation = xlCalculationManual .WindowState = xlNormal ' .WindowState = xlMinimized End With sgStart = Timer Set ws = Worksheets(DATA_SHEET_NAME) lEndRow = MAX_DATAS_COUNTS + HEADER_ROWS '検索対象キー値取得 Call getKeys(vKeys) ReDim sKeys(LBound(vKeys) To UBound(vKeys)) For i = LBound(vKeys) To UBound(vKeys) sKeys(i) = CStr(vKeys(i)) Next i With ws 'Filter対象レンジを設定 Set r = .Range(.Cells(1, KEY_COL), .Cells(lEndRow, KEY_COL)) End With With r For i = LBound(sKeys) To UBound(sKeys) 'AutoFilterクリア .AutoFilter 'Filter実行 .AutoFilter Field:=1, Criteria1:=sKeys(i), Operator:=xlFilterValues If .SpecialCells(xlCellTypeVisible).Count > HEADER_ROWS Then lMatchCount = lMatchCount + .SpecialCells(xlCellTypeVisible).Count - HEADER_ROWS End If Next i 'AutoFilter解除 .AutoFilter End With sgStop = Timer With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic .WindowState = xlNormal End With Debug.Print Format$(sgStop - sgStart, "0.00") End Sub Private Sub getKeys(ByRef vKeys() As Variant) Dim lEndRow As Long Dim lItems As Long Dim lValue As Long Dim i As Long ReDim vKeys(MAX_KEYS_COUNTS - 1) lEndRow = MAX_KEYS_COUNTS + HEADER_ROWS With Worksheets(KEY_SHEET_NAME) For i = HEADER_ROWS + 1 To lEndRow vKeys(i - HEADER_ROWS - 1) = .Cells(i, 1).Value Next i End With End Sub
まとめ(のようなもの)
- フィルターを適用するワークシートをアクティブにしない方が速かった。
- ScreenUpdateing = False は、フィルターを適用するワークシートがアクティブな場合には、効果が大きいが、そうでない場合は、効果がほとんど認められなかった。
- Windowを最小化しても、あまり高速化へのメリットはなかった。
今回のテストでは、ScreenUpdatingの状態に関わらず、フィルターを適用するワークシートをアクティブにしない方が速くなっている。
では、フィルターを適用するワークシートが「表示されていなければ、いいのか?」というと、
「Windowを最小化」により該当ワークシートを非表示状態にして効果が認められるのは、
フィルターを適用するワークシートをアクティブにして、かつ ScreenUpdating = True の場合だけだったので、表示されていなければ、効果があるわけではないようだ。
一方で、「該当ワークシートを非表示にする」というのは、別のワークシートをアクティブ化するという事と同等なので、これは「効果はある」ことになる。
結局の所、ScreenUpdatingがFalseになっていても、フィルターを適用するワークシートがアクティブの場合には、アクティブシートであるが故の何かが、裏で動いていると考えるのが妥当なのかもしれない。
というか、私の頭ではそれしか思い浮かばない。
誰か、わかる方がいらっしゃいましたら教えて下さい。
フィルター以外でも効果があるのかは、要確認。
でも、きっと・・・
忘れて何もしないような気がする。
追記
行削除(2019/5/5)
行の削除処理で比較してみた。
Public Sub deleteRows(ByVal acsh As Long, ByVal doScreenUpdating As Boolean) Const END_ROW As Long = 10000 Dim ws As Worksheet Dim sgStart As Single Dim sgStop As Single Dim i As Long sgStart = Timer Application.ScreenUpdating = doScreenUpdating If acsh = 1 Then Worksheets(1).Activate Else Worksheets(2).Activate End If Set ws = Worksheets(1) With ws .Cells.ClearContents .Cells(1, 1).Value = 1 .Cells(2, 1).Value = 2 .Range("A1:A2").AutoFill Destination:=.Range("A1:A" & CStr(END_ROW)), Type:=xlFillDefault For i = END_ROW To 1 Step -2 .Rows(i).Delete Next i End With Worksheets(1).Activate Application.ScreenUpdating = True sgStop = Timer Debug.Print "Active Sheet:" & CStr(acsh), Format$(sgStop - sgStart, "0.00") End Sub
結果
Active Sheet: 1 ScreenUpdating: True Time[sec]: 3.64 Active Sheet: 1 ScreenUpdating: False Time[sec]: 0.97 Active Sheet: 2 ScreenUpdating: True Time[sec]: 0.89 Active Sheet: 2 ScreenUpdating: False Time[sec]: 0.84
やっぱり、処理するシート以外をアクティブシートにした方が速い。
その場合には、ScreenUpdating = False としても、大きな効果は認められない。(見えない所で処理しているのだから、当たり前といえば当たり前か・・・)
結構使えるかもしれない・・・
【VBA】割り算を使わないで、数値の2進数表示を取得する(負値対応済み)
最初に断っておきますが、この記事は半分ネタです。
あえて、面倒くさいことしてます。
私がやりたかっただけです。
基本に則って2進表示を求めたい方は、
とか、して下さい。
但し、10進数の2進数表示した文字列を取得する関数は、探せば結構出てきますが
大体は、2で割って余りを求めて・・・
でも、負の数まで考慮されているものはほとんど無いようです。
私が見つけた1件でも、値によってはオーバーフローして、十分な検証はされていないようでした。
WorksheetFunction.Dec2Bin は、
数値 < -512 または数値 > 511 の場合、エラー値 #NUM! が返されます。
WorksheetFunction.Dec2Bin メソッド (Excel)
と、あまり使い物にならないかもしれません。
コード その1
割り算を使った方法は、上位の桁から処理していくが、割り算を使用しないということは、その逆で、下位から処理を行っていきます。
2^0 の桁 から Integerなら、2^15 の桁に向かって処理を行います。
流れとしては
最初に、変換したいデータと 1 ( = 2^0 )のAnd を取る。
奇数の場合、2^0の桁は 1 なので
1 And 1 ===> 1
となり、
偶数の場合、2^0の桁は 0 なので
0 And 1 ===> 0
となる。
And を取った結果が、2^0 の桁の値となる。
これを桁を、2^1の桁、2^2の桁と、上位方向にずらして繰り返していく。
「And演算子って何?」とか、
「なんで数値同士でAndなの?」とか
「A And B って、A かつ B じゃないの?」
という方は、以下のリンクをどうぞ。
(解説の下の方に書いてあります。)
docs.microsoft.com
以下が、その処理を行うコードです。
但し、Integer も Long も符号付き故に、大抵は、最上位bitでの処理に苦しみます。(多分、私だけではないと思う。)
結局は、それを回避するためにゴチャゴチャと・・・
微妙に違うところはありますが、ほぼ分かると思います。
コード その2
VBAで、エンディアンの変換をやろうとしたら、やっぱりハマった - 空腹おやじのログと備忘録 のおまけで書いたコードと似たような手法。
最初に変換したい値を16進の文字列に変換して、16進数1文字につき、2進数4文字に変換していく。
値の正負を意識する必要がない。
オーバーフローの心配もなく、手っ取り早い。
お気軽に使いたいなら、こちらの方がおすすめ。
Integer(16bit)版のみ掲載
Long(32bit)版が欲しい方は、適当にアレンジして下さい。そんなに難しくはないと思いますので。
あぁ、今日も自己満足の世界に・・・
【VBA】For ループの罠(?)
次のコードを実行するとどうなると思いますか?
Public Sub foo() Dim i As Long For i = &H7FFFFFFE To &H7FFFFFFF Debug.Print i Next i End Sub
もうひとつ
Public Sub bar() Dim i As Long i = &H7FFFFFFE Do Debug.Print i i = i + 1 Loop Until i > &H7FFFFFFF End Sub
ちなみに、
&H7FFFFFFE => 2147483646
&H7FFFFFFF => 2147483647
です。
どちらも、
2147483646 2147483647
となると思った方
・
・
・
・
・
残念ですが、半分だけ正解です。
bar の方が、予想はしやすいと思いますが・・・
どちらも 2147483646 と 2147483647 は出力されます。
でもその後に、どちらも、オーバーフローが発生します。
上記Forループの場合、変数 i がLongなので、Longの上限値である &H7FFFFFFF までループ可能かと思っていたら、内部で&H7FFFFFFF + 1 してからループを終了するみたいです。
( i = &H7FFFFFFF の処理を終了後、i をインクリメントして i > &H7FFFFFFF となったことでループ終了と判断していると推測される)
ただ、For ループの方のスクリーンショットで見える -2147483648 は、Long の最小値(&H80000000)であるので、この状況についてはよくわからない。
Longの上限(&H7FFFFFFF)を超えた &H80000000(正の値)が、Longの変数領域に負の値の &H80000000 として存在しているためなのか?
内部でのBitは &H80000000 で一致していても、実際には、Longの上限(&H7FFFFFFF)+1(+2147483648 > 0)となるためオーバーフローと判断されたのだろうか?
ちなみに、イミディエイトウィンドウで
? &H7FFFFFFF + 1
とやっても、オーバーフローが発生する。
上記のbarの方は予想はできるけど、For の挙動は予想できなかった。
別の作業で同様の処理をやっていて、順調に進んでいった最後のところで
「えっ、なんでオーバーフローすんの?」って驚いた。
その原因がこんな感じでした。
結 論
- For ループは、ループ変数の型の上限値までループさせるとオーバーフローする。
- ループ変数の型は、余裕のあるサイズにしよう!!!
- 境界には気をつけよう
あぁ、今日も余計な手間で疲れた・・・
回答が・・・
後からブロググループのページを見て・・・
がっかり orz
なんのために結果を隠したんだよ・・・
最初から答えが出てるじゃん。
当該画像の前に別の画像を追加しても、ブログページに表示される画像は変わらないんですね。
しょうがないので、最初から隠さずに全部表示することにしました。
つまらん!
VBAのDictionary の Key について実験してみた
VBAのDictionaryのKeyには、数値、文字(数字を含む)、オブジェクト等が使えます。
そんな中で、ちょっと気になったことがあったので、実験してみました。
データ型が異なる同一値の数値を指定してみる
「データ型が異なる別々の値」をKeyとしてDictionaryに追加した後、それぞれのItemを、「値が同じで、異なるデータ型」のKeyを指定して呼び出してみる。
1.呼び出し検証コード
Public Sub 数値型追加テスト() Dim dic As New Dictionary Dim v As Variant dic.Add CByte(0), "Byte" dic.Add 1, "Integer" dic.Add 2&, "Long" dic.Add 3@, "Currency" dic.Add 4!, "Single" dic.Add 5#, "Double" For Each v In dic.Keys Debug.Print TypeName(v), v Next v Debug.Print "----- " & "Integer" & " -----" Debug.Print dic(0) Debug.Print dic(1) Debug.Print dic(2) Debug.Print dic(3) Debug.Print dic(4) Debug.Print dic(5) Debug.Print "----- " & "Long" & " -----" Debug.Print dic(0&) Debug.Print dic(1&) Debug.Print dic(2&) Debug.Print dic(3&) Debug.Print dic(4&) Debug.Print dic(5&) Debug.Print "----- " & "Currency" & " -----" Debug.Print dic(0@) Debug.Print dic(1@) Debug.Print dic(2@) Debug.Print dic(3@) Debug.Print dic(4@) Debug.Print dic(5@) Debug.Print "----- " & "Single" & " -----" Debug.Print dic(0!) Debug.Print dic(1!) Debug.Print dic(2!) Debug.Print dic(3!) Debug.Print dic(4!) Debug.Print dic(5!) Debug.Print "----- " & "Double" & " -----" Debug.Print dic(0#) Debug.Print dic(1#) Debug.Print dic(2#) Debug.Print dic(3#) Debug.Print dic(4#) Debug.Print dic(5#) Debug.Print "----- " & "Type Name" & " -----" Debug.Print TypeName(dic.Keys(0)) Debug.Print TypeName(dic.Keys(1)) Debug.Print TypeName(dic.Keys(2)) Debug.Print TypeName(dic.Keys(3)) Debug.Print TypeName(dic.Keys(4)) Debug.Print TypeName(dic.Keys(5)) End Sub
実行結果
call 数値型追加テスト Byte 0 Integer 1 Long 2 Currency 3 Single 4 Double 5 ----- Integer ----- Byte Integer Long Currency Single Double ----- Long ----- Byte Integer Long Currency Single Double ----- Currency ----- Byte Integer Long Currency Single Double ----- Single ----- Byte Integer Long Currency Single Double ----- Double ----- Byte Integer Long Currency Single Double ----- Type Name ----- Byte Integer Long Currency Single Double
- 同一値であれば、データ型が異なっていてもItemを呼び出しできる。
- 呼び出したItemは、Addした際のデータ型を保持している。
おまけのテスト
Public Sub hoge() Dim v1 Dim v2 v1 = 10 v2 = 10& Debug.Print v1 = v2 Debug.Print TypeName(v1) = TypeName(v2) Debug.Print 10 = 10& Debug.Print TypeName(10) = TypeName(10&) End Sub
実行結果
call hoge True False True False
これなら、上のような結果になるのは納得。
2.追加検証コード
データ型が異なる同一値をKeyとしてDictionaryに追加してみる。
Public Sub 数値型追加テスト2() Dim dic As New Dictionary Dim v As Variant dic.Add CByte(0), "Byte" dic.Add 0, "Integer" dic.Add 0&, "Long" dic.Add 0@, "Currency" dic.Add 0!, "Single" dic.Add 0#, "Double" End Sub
実行結果
- データ型が異なっていても、値が同一であれば追加はできない。
Nullを指定してみる
検証コード
Public Sub Null追加テスト() Dim dic As New Dictionary dic.Add Null, "NULL" Debug.Print dic.Exists(Null), dic.Item(Null) End Sub
実行結果
call Null追加テスト True NULL
- NullはKeyとして追加できる。
- NullがKeyとして存在するか確認できる。
- Nullをキーとして、Itemを呼び出せる。
空文字列を指定してみる
Public Sub NullString追加テスト() Dim dic As New Dictionary dic.Add "", "Null String" Debug.Print dic.Exists(""), dic.Item("") End Sub
実行結果
call NullString追加テスト True Null String
- 空文字はKeyとして追加できる。
- 空文字がKeyとして存在するか確認できる。
- 空文字をKey指定してItemを呼び出せる。
Binaryを指定してみる
検証コード
Public Sub Binary追加テスト() Dim dic As New Dictionary dic.Add vbTab, "Tab" dic.Add vbCr, "CR" dic.Add vbLf, "LF" dic.Add vbCrLf, "CRLF" dic.Add vbNullChar, "\0" Debug.Print dic.Exists(vbTab), dic.Item(vbTab) Debug.Print dic.Exists(vbCr), dic.Item(vbCr) Debug.Print dic.Exists(vbLf), dic.Item(vbLf) Debug.Print dic.Exists(vbCrLf), dic.Item(vbCrLf) Debug.Print dic.Exists(vbNullChar), dic.Item(vbNullChar) End Sub
実行結果
call Binary追加テスト True Tab True CR True LF True CRLF True \0
- BinaryはKeyとして追加できる。
- BinaryがKeyとして存在するか確認できる。
- BinaryをKey指定してItemを呼び出せる。
テスト後に気が付いたけど、Binaryって、要はByteデータなので、当たり前なのかも。
配列を指定してみる
検証コード
Public Sub 配列追加テスト() Dim dic As New Dictionary Dim ar11(1) As Long ar11(0) = 11 ar11(1) = 12 dic.Add ar11(0), ar11(0) * 10 dic.Add ar11(1), ar11(1) * 10 Debug.Print dic.Exists(ar11(0)), dic.Item(ar11(0)) Debug.Print dic.Exists(ar11(1)), dic.Item(ar11(0)) Debug.Print dic.Exists(11), dic.Item(11) Debug.Print dic.Exists(12), dic.Item(12) dic.Add ar11, ar11(0) * 100 + ar11(1) * 100 Debug.Print dic.Exists(ar11), dic.Item(ar11) End Sub
実行結果
- 配列の要素は、Keyとして追加できる。
- 配列の要素がKeyとして存在するか確認できる。
- 配列の要素をKey指定してItemを呼び出せる。
- 配列は、Keyとして追加できない。
VBAで、エンディアンの変換をやろうとしたら、やっぱりハマった
Windowsを使っていると、ソケット通信のコーディングでもしない限り、ほとんど意識する事がないであろうビッグエンディアンとリトルエンディアンに関する事です。
まず、「エンディアンって何それ美味しいの?」って人は、こちらをどうぞ。
ja.wikipedia.org
やろうとしているのは、1Byte単位で、上位下位を入れ替えるというもので、例えば、
Integerなら、16進表記で、&H1234 を &H3412 に
Longなら、16進表記で、&H12345678 を &H78563412
に変換するというものです。
まず、Integerから。サクッとこんな感じかな?
Public Function convertEndian16NG(ByVal iValue As Integer) As Integer Dim byHighByte As Byte Dim byLowByte As Byte byHighByte = (iValue And &HFF00) \ &H100 byLowByte = iValue And &HFF convertEndian16NG = (byLowByte * &H100) Or byHighByte End Function
じゃあ、テスト。
? hex(convertEndian16NG(&H1234)) 3412
OK。もうひとつ。
? hex(convertEndian16NG(&H8765))
orz
何処?
? hex(iValue And &HFF00) 8700
OK
? typename(iValue And &HFF00) Integer
OK
? hex((iValue And &HFF00)\&H100) FF87
ん???
87 になるはずが、FF87 になってる!
最上位ビットが1だから(別の言い方をすれば、負の値だから)、右シフトしてきた時に、頭が0でなくて、1になるのか・・・
忘れてた。
じゃあ、最上位ビットが "1" でなければいいから、強制的に Long になるように
iValue と And を取る &HFF00 を Integer から Long に変えるおまじないをしよう。( &HFF00 → &HFF00& )
? &HFF00 -256 ? &HFF00& 65280
Public Function convertEndian16NG2(ByVal iValue As Integer) As Integer Dim byHighByte As Byte Dim byLowByte As Byte byHighByte = (iValue And &HFF00&) \ &H100 byLowByte = iValue And &HFF convertEndian16NG2 = (byLowByte * &H100) Or byHighByte End Function
再テスト
? hex(convertEndian16NG2(&H1234)) 3412 ? hex(convertEndian16NG2(&H8765)) 6587
OK。
もうひとつ
? hex(convertEndian16NG2(&H1080))
orz
今度は何処ですか・・・
? byLowByte * &H100
32768(&H8000 ::正値 Integerで &H8000 は、-32768)だから、Integerの上限値(32767 : &H7FFF)を超えてしまうのね。
Byte と Integer の掛け算だから、Integerになる想定だったのに、Integerに収まらなくてオーバーフローになっちゃうのね。
じゃあ、下位の1Byteは最上位ビットを除いて処理して、後からその分を補正してやろう。
Public Function convertEndian16(ByVal iValue As Integer) As Integer Dim byHighByte As Byte Dim byLowByte As Byte Dim iNewValue As Integer byHighByte = (iValue And &HFF00&) \ &H100 byLowByte = iValue And &HFF iNewValue = ((byLowByte And &H7F) * &H100) Or byHighByte If (byLowByte And &H80) = &H80 Then iNewValue = iNewValue Or &H8000 End If convertEndian16 = iNewValue End Function
再々テスト
? hex(convertEndian16(&H1234)) 3412 ? hex(convertEndian16(&H8765)) 6587 ? hex(convertEndian16(&H1080)) 8010 ? hex(convertEndian16(&HFEDC)) DCFE ? hex(convertEndian16(&H0F08)) 80F ? hex(convertEndian16(&HFFFF)) FFFF ? hex(convertEndian16(0)) 0
とりあえず、良さげ。
以上を踏まえて、Long版は・・・
と行こうかと思ったら、Longの場合、Integerの場合のように、上位の整数型が無いから出来ないじゃん。
(64bitバージョンには、LongLongがあるの?うちの娘に入ってるの、32bitバージョンだから・・・)
ここまでやっておいて、どうするつもりなの???
・
・
・
・
・
今更なんですが、IntegerでもLongでも、もっと簡単に出来る方法を思いついちゃったんですよ。
さっきまでの前振りは何だったの?
おまけ
データ型 | 識別子の型文字 |
---|---|
Integer | % |
Long | & |
Decimal | @ |
Single | ! |
Double | # |
String | $ |
? typename(1) Integer ? typename(1%) Integer ? typename(1&) Long ? typename(1@) Currency ? typename(1!) Single ? typename(1#) Double
ExcelのAutoFilterの抽出条件には、配列が指定できる・・・でも、ちょっと注意しないといけない事もある
AutoFilterの抽出条件に配列が使用できるとの事で、試してみた際にハマったので・・・
こんなデータを用意。
まずは、1件抽出するコード。こんな感じ?
Public Sub doAutoFilter() Dim r As Range Set r = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion r.AutoFilter Field:=1, Criteria1:=3 End Sub
実行してみる。
3が抽出されている。問題ない。
では、3件抽出してみる。
Public Sub doAutoFilter2() Dim r As Range Set r = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion r.AutoFilter Field:=1, Criteria1:=Array(2, 4, 6), Operator:=xlFilterValues End Sub
実行。
?1件も抽出されない。
「マクロの記録」で同じことをやってみる。
Sub Macro1() ' ' Macro1 Macro ' ' Range("A1:A21").Select Selection.AutoFilter ActiveSheet.Range("$A$1:$A$21").AutoFilter Field:=1, Criteria1:=Array("2", _ "4", "6"), Operator:=xlFilterValues End Sub
???抽出するデータが数値なのに、Arrayの中身が文字列になっている!!!
じゃあ、こう?
Public Sub doAutoFilter2() Dim r As Range Set r = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion ' r.AutoFilter Field:=1, Criteria1:=Array(2, 4, 6), Operator:=xlFilterValues r.AutoFilter Field:=1, Criteria1:=Array("2", "4", "6"), Operator:=xlFilterValues End Sub
大丈夫そう。
セルのデータの型に関係なく、Arrayの中身は、文字列でないと駄目らしい・・・
ということは、セルの書式が変わると抽出されないのでは?
セルの表示を小数第1位まで表示させたら・・・
やっぱり抽出されません。 orz
勘弁して下さい・・・
やっぱり日付でも・・・
VBAでFindFirstFile、FindNextFileを使ってファイルリストを取得する
2022/10/20 追記
この記事のコードを FindFirstFileW を使って Unicode 対応した記事がありますので、そちらも ご覧ください。
z1000s.hatenablog.com
ことりちゅんさん(id:Kotori-ChunChun)のところで、FileSystemObjectとDirを使って、ファイルパスの一覧を取得する速度の比較をしている記事を見つけました。
kotori-chunchun.hatenablog.com
www.excel-chunchun.com
個人的には、FindFirstFile、FindNextFileという選択肢もあったので、比べてみることにしました。
データ
62,200個の0Byteファイルを作成しました。(ファイル名の取得だけだから、中身はいらないでしょ。うちの娘(使用年数から言えば、もう婆さんか?)のssdの空きも少ないし・・・)
データ生成コード
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" _ (ByVal lpPath As String) As Long Public Const TARGET_FOLDER_ROOT As String = "C:\Datas\FileListTest\Data\" Public Sub createData() Dim sSubFolder As String Dim sFolderPath As String Dim iFileNo As Integer Dim i As Long Dim j As Long Dim k As Long Dim l As Long For i = 1 To 10 For j = 1 To 5 For k = 1 To 5 sSubFolder = "A00\B0000\C0000\" Mid$(sSubFolder, 2, 2) = Format$(i, "00") Mid$(sSubFolder, 6, 4) = Format$(j + 1000, "0000") Mid$(sSubFolder, 12, 4) = Format$(k + 2000, "0000") sFolderPath = TARGET_FOLDER_ROOT & sSubFolder Call createFolder(sFolderPath) For l = 1 To 200 iFileNo = FreeFile Open sFolderPath & Format$(l, "000") & ".txt" For Output As iFileNo Close iFileNo Next l Next k sSubFolder = "A00\B0000\" Mid$(sSubFolder, 2, 2) = Format$(i, "00") Mid$(sSubFolder, 6, 4) = Format$(j + 1000, "0000") sFolderPath = TARGET_FOLDER_ROOT & sSubFolder For l = 1 To 200 iFileNo = FreeFile Open sFolderPath & "C" & Format$(l, "000") & ".txt" For Output As iFileNo Close iFileNo Next l Next j sSubFolder = "A00\" Mid$(sSubFolder, 2, 2) = Format$(i, "00") sFolderPath = TARGET_FOLDER_ROOT & sSubFolder For l = 1 To 200 iFileNo = FreeFile Open sFolderPath & "B" & Format$(l, "000") & ".txt" For Output As iFileNo Close iFileNo Next l Next i sFolderPath = TARGET_FOLDER_ROOT For l = 1 To 200 iFileNo = FreeFile Open sFolderPath & "A" & Format$(l, "000") & ".txt" For Output As iFileNo Close iFileNo Next l Debug.Print "Done." End Sub Public Function createFolder(ByVal sFolderPath As String) As Boolean Dim sPath As String Dim lResult As Long If Right$(sFolderPath, 1) <> "\" Then sPath = sFolderPath & "\" Else sPath = sFolderPath End If lResult = MakeSureDirectoryPathExists(sPath) createFolder = CBool(lResult <> 0) End Function
テスト用コード(FindFirstFile版)
Private Const MAX_PATH As Long = 260& Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternateFileName As String * 14 End Type Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _ (ByVal Filename As String, _ ByRef FindData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _ (ByVal hFind As Long, _ ByRef FindData As WIN32_FIND_DATA) As Long Private Declare Function FindClose Lib "kernel32" _ (ByVal hFind As Long) As Long Private Const INVALID_HANDLE_VALUE As Long = -1 'Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20 Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10 'Private Const FILE_ATTRIBUTE_HIDDEN As Long = &H2 'Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80 'Private Const FILE_ATTRIBUTE_READONLY As Long = &H1 'Private Const FILE_ATTRIBUTE_SYSTEM As Long = &H4 'Private Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100 Public Sub fffTest() Dim colPaths As Collection Dim sgStart As Single Dim sgStop As Single sgStart = Timer Set colPaths = New Collection Call getFilePaths("C:\Datas\FileListTest\Data", colPaths) sgStop = Timer Debug.Print Format$(sgStop - sgStart, "0.00") & " sec." If colPaths.Count > 0 Then Debug.Print colPaths.Count Else Debug.Print "No files found." End If End Sub Public Function getFilePaths(ByVal sTargetFolder As String, ByRef colFilePaths As Collection, Optional ByVal sTargetPattern As String = "*") As Long Dim sTargetFolderY As String Dim sTargetPathName As String Dim hFind As Long Dim fd As WIN32_FIND_DATA Dim sFileName As String Dim sPath As String If Right$(sTargetFolder, 1) <> "\" Then ' sTargetFolderY = sTargetFolder & "\" Else sTargetFolderY = sTargetFolder End If sTargetPathName = sTargetFolderY & sTargetPattern hFind = FindFirstFile(sTargetPathName, fd) If hFind = INVALID_HANDLE_VALUE Then getFilePaths = INVALID_HANDLE_VALUE Exit Function End If Do 'fd.cFileNameは固定長文字列で、本来のファイル名以降の部分にはvbNullCharが埋められているので 'それらを削除する必要がある sFileName = deleteNullChar(fd.cFileName) If sFileName = "." Then 'カレントフォルダは処理しない GoTo LOOP_CONTINUE ElseIf sFileName = ".." Then '親フォルダは処理しない GoTo LOOP_CONTINUE End If If (fd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then 'フォルダなら再帰処理させるためにパスを生成 sPath = sTargetFolderY & sFileName '再帰呼び出し Call getFilePaths(sPath, colFilePaths, sTargetPattern) Else 'ファイルならコレクションに追加 colFilePaths.Add sTargetFolderY & sFileName End If LOOP_CONTINUE: '次のファイルが見つからなくなるまでループ Loop Until FindNextFile(hFind, fd) = 0 Call FindClose(hFind) getFilePaths = 0 End Function Private Function deleteNullChar(ByVal sSource As String) As String Dim lPos As Long lPos = InStr(sSource, vbNullChar) If lPos > 0 Then deleteNullChar = Left$(sSource, lPos - 1) Else deleteNullChar = sSource End If End Function
テストコード(Dir版)
ことりちゅんさん(id:Kotori-ChunChun)のところの処理を流用。
但し、test_GetFileListTmpfileの時間計測部分と結果表示部分のみアレンジ。
- Time→Timer
- 結果表示フォーマット 0.00 sec.
- ファイル数表示追加
Const WshHide = 0 '非表示 Const WshNormalFocus = 1 '通常サイズ Function TrimEx(TargetString As String, Optional TrimLeft As Boolean = True, Optional TrimRight As Boolean = True) As String Dim reg_pattern As String If TrimLeft And TrimRight Then reg_pattern = "(?:^\s+|\s+$)" ElseIf TrimLeft Then reg_pattern = "^\s+" ElseIf TrimRight Then reg_pattern = "\s+$" Else TrimEx = TargetString Exit Function End If With CreateObject("VBScript.RegExp") .Pattern = reg_pattern .IgnoreCase = False .Global = True TrimEx = .Replace(TargetString, "") End With End Function Function GetFileListTmpfile(FolderLocation As String, Optional ShowCmdWindow As Boolean = True) As String() GetFileListTmpfile = Split(vbNullString) Dim tmpfile As String Dim filelist() As String With CreateObject("Scripting.FileSystemObject") If Not .FolderExists(FolderLocation) Then Debug.Print "* Error * Folder(" & FolderLocation & ") not found" Exit Function End If Do tmpfile = .GetSpecialFolder(2) & "\" & .GetTempName Loop While .FileExists(tmpfile) End With CreateObject("Wscript.Shell").Run "cmd /U /C dir /S /B /A-D """ & FolderLocation & """ > " & tmpfile, _ IIf(ShowCmdWindow, WshNormalFocus, WshHide), True 'コマンドプロンプト表示がONで強制終了(中断)された時の対策 With CreateObject("Scripting.FileSystemObject") If Not .FileExists(tmpfile) Then Exit Function End If End With With CreateObject("ADODB.Stream") .Charset = "Unicode" .Open .LoadFromFile tmpfile filelist = Split(TrimEx(.ReadText), vbCrLf) .Close End With Kill tmpfile GetFileListTmpfile = filelist End Function Sub test_GetFileListTmpfile() Dim t As Single t = Timer Dim V As Variant 'エクセルが応答不能になる。使用する場合は超注意 'Application.Interactive = False V = GetFileListTmpfile("C:\Datas\FileListTest\Data", True) 'Application.Interactive = True Debug.Print Format$(Timer - t, "0.00") & "sec." Debug.Print UBound(V) - LBound(V) + 1 End Sub
実行結果
call fffTest 0.31 sec. 62200 call test_GetFileListTmpfile 7.27sec. 62200
やっぱりAPI速いっすねぇ。1桁違います。
件数は同じですけど、検索順は違いますよ。詳細は省きますけど・・・
ちなみに、Visual Studio 2017 C++で同様の処理を実行してみたら・・・
さらにその半分以下になりました。
C++のソースは省略。VBAのソースのCollectionがVectorになったくらいだから、誰も見ないでしょ?
おまけ
FindFirstFile、FindNextFileのファイルの検索順は、ファイルシステムに依存があります。
とりあえず、こんなコードで
Public Sub fffTest2() Dim colPaths As Collection Dim v As Variant Dim sFolderPath As String Dim sFileName(4) As String Dim iFileNo As Integer Dim i As Long sFolderPath = "D:\FFF_Test\" Call createFolder(sFolderPath) On Error Resume Next Kill sFolderPath & "*" On Error GoTo 0 sFileName(0) = "003.txt" sFileName(1) = "005.txt" sFileName(2) = "004.txt" sFileName(3) = "002.txt" sFileName(4) = "001.txt" For i = 0 To 4 iFileNo = FreeFile Open sFolderPath & sFileName(i) For Output As iFileNo Close iFileNo Call Sleep(3000) Next i Set colPaths = New Collection Call getFilePaths("D:\FFF_Test", colPaths) If colPaths.Count > 0 Then Debug.Print "FileSystem:" & getFileSystemName("D:\") For Each v In colPaths Debug.Print v Next v Debug.Print "Done." Else Debug.Print "No files found." End If End Sub
実行結果は以下の通り。
Dドライブは、USBメモリで、ファイルシステムの違いは、USBメモリの差し替えで実現しています。
(これのためだけに、1個のUSBメモリをNTFSでフォーマットしました。)
call fffTest2 FileSystem:exFAT D:\FFF_Test\003.txt D:\FFF_Test\005.txt D:\FFF_Test\004.txt D:\FFF_Test\002.txt D:\FFF_Test\001.txt Done. call fffTest2 FileSystem:NTFS D:\FFF_Test\001.txt D:\FFF_Test\002.txt D:\FFF_Test\003.txt D:\FFF_Test\004.txt D:\FFF_Test\005.txt Done. call fffTest2 FileSystem:FAT32 D:\FFF_Test\003.txt D:\FFF_Test\005.txt D:\FFF_Test\004.txt D:\FFF_Test\002.txt D:\FFF_Test\001.txt Done.
NTFSはファイル名順
exFatとFAT32は、ファイル作成順
となってます。
厳密には、CollectionをFor Eachで出力している時点で駄目なんだけど、簡易的な確認なので、まぁ良しとしてしまえ。
ここにも
The order in which this function returns the file names is dependent on the file system type. With the NTFS file system and CDFS file systems, the names are usually returned in alphabetical order. With FAT file systems, the names are usually returned in the order the files were written to the disk, which may or may not be in alphabetical order. However, as stated previously, these behaviors are not guaranteed.
と書いてありました。
さらに、Dir版でも試してみたところ、FindFirstFile版と同じ結果になりました。
これは、ちょっとした発見でした。
あぁ、なんか話が全然別の方に行ってる・・・