VBAの＄付きの文字列関数
VBAの文字列関数には＄付きの物がありますが、ネットで見るコードではほとんど見かけません。Microsoftのサイトで関数を検索しても、出てくるのは$なしばかり。
何が違うのと言われれば、
VBA の文字列関数の中には 2 種類のバリエーションを持つものがあります。1 つは文字列を返し、もう 1 つは文字列型 (String) のバリアント値を返します。文字列を返す関数名にはドル記号 ($) が含まれます。たとえば、Chr$、Format$、LCase$、Left$、LTrim$、Mid$、Right$、RTrim$、Space$、Trim$、UCase$ などがあります。文字列型のバリアント値を返す関数にはドル記号は含まれません。これらの関数名は、Chr、Format、Lcase、Left、Ltrim、Mid、Right、Rtrim、Space、Trim、Ucase などになります。前者の関数はすばやく結果を返しますが、Null 値を使用して呼び出すとエラーが発生します。文字列型のバリアント値を返す関数では、Null 値を問題なく使用できます。
文字列の一部を返す | Microsoft Docs
２つの違いをざっくり言うと、
- 復帰値の型が異なる
- パフォーマンスが異なる（通常なら無視できるレベル）
- 文字列を取り出す元の文字列式で扱えるデータの型が異なる
です。
| 項目 | $付き | $なし |
|---|---|---|
| 復帰値 | 文字列型 (String) | 文字列型 (String) のバリアント値 |
| Null値対応 | 使用不可 | 使用可 |
Nullをパラメータとして渡した場合の違いはこんな感じ。
$なしは、エラーの発生もなく、Null（文字列ではない）を返している。
文字列ではないというのは、
? typename(Left(Null,2))
と実行すれば
Null
と返ってくることで確認できる。
$ありでは、実行時エラー '94'が発生している。
$ありなしでのパフォーマンスの比較は、以下のサイトで行われていたが
基本的には記述通り、$あり ＞ $なし となっている。
代入先の変数の型で状況が変わるのは、なるほどといった感じ。
■T'sWare Access Labo #32 〜＄付き関数のメリットとは？〜
別に、$付きでも$なしでも、どっちを使ってもいいんですよ。最終的に、正しい結果が得られるのであれば・・・
ちなみに私は、$付き派です。
「だから、どうした？」とか「どうして？」と聞かれても困りますが・・・
VBAで、エンディアンの変換をやろうとしたら、やっぱりハマった
Windowsを使っていると、ソケット通信のコーディングでもしない限り、ほとんど意識する事がないであろうビッグエンディアンとリトルエンディアンに関する事です。
まず、「エンディアンって何それ美味しいの？」って人は、こちらをどうぞ。
ja.wikipedia.org
やろうとしているのは、1Byte単位で、上位下位を入れ替えるというもので、例えば、
Integerなら、１６進表記で、&H1234 を &H3412 に
Longなら、１６進表記で、&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の抽出条件に配列が使用できるとの事で、試してみた際にハマったので・・・
こんなデータを用意。
まずは、１件抽出するコード。こんな感じ？
Public Sub doAutoFilter() Dim r As Range Set r = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion r.AutoFilter Field:=1, Criteria1:=3 End Sub
実行してみる。
３が抽出されている。問題ない。
では、３件抽出してみる。
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
実行。
？１件も抽出されない。
「マクロの記録」で同じことをやってみる。
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の中身は、文字列でないと駄目らしい・・・
ということは、セルの書式が変わると抽出されないのでは？
セルの表示を小数第１位まで表示させたら・・・
やっぱり抽出されません。 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個の０Byteファイルを作成しました。（ファイル名の取得だけだから、中身はいらないでしょ。うちの娘（使用年数から言えば、もう婆さんか？）の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速いっすねぇ。１桁違います。
件数は同じですけど、検索順は違いますよ。詳細は省きますけど・・・
ちなみに、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メモリの差し替えで実現しています。
（これのためだけに、１個の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版と同じ結果になりました。
これは、ちょっとした発見でした。
あぁ、なんか話が全然別の方に行ってる・・・
Excelのワークシート名取得 ADOでOpenSchema と Workbooks.Open を比べてみた
ADOというとデータベースに使うというイメージが強いような感じがしますが、Excelに対しても使えます。
Excelのワークブックを指定して、ワークシート名の一覧取得を、ADOの使用有無で行ってみます。
使用環境
Windows 10 Home
Excel 2013
CPU：古い（恥ずかしいので秘密）
メモリ：少し（同上）
使用する環境によっては、参照設定や接続文字列が変えないといけない場合がありえますのでご注意ください。
ADOを使用する場合
モジュールレベルの変数
コネクション変数をモジュールレベルで宣言しておきます。
モジュール内で、共用するためです。
Private cn_ As ADODB.Connection
接続
Public Function connectDB(ByVal sDBPath As String, Optional ByVal bExistsHeaderRow As Boolean = True) As Long Dim sExistsHeaderRow As String Dim sConnectionString As String If bExistsHeaderRow = True Then sExistsHeaderRow = "Yes" Else sExistsHeaderRow = "No" End If ' HDR=Yes===>先頭行を列名とみなす ' 『IMEX=1』とはドライバにインポート モードを使用するように指示して ' 混在データが文字列に変換されることを強制するものらしい sConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & sDBPath & ";" & _ "Extended Properties=""Excel 12.0 Xml;" & _ "HDR=" & sExistsHeaderRow & ";" & _ "IMEX=1;""" On Error GoTo ERR_CONNECT_DB If cn_ Is Nothing Then Set cn_ = New ADODB.Connection End If If cn_.State <> adStateOpen Then cn_.Open sConnectionString End If connectDB = 0 Exit Function ERR_CONNECT_DB: Debug.Print Err.Number & ":" & Err.Description connectDB = Err.Number End Function
切断
Public Sub disconnectDB() If Not cn_ Is Nothing Then If cn_.State <> adStateClosed Then cn_.Close End If Set cn_ = Nothing End If End Sub
シート名取得
Public Function getSheetNames(ByRef sSheetNames() As String) As Long Dim rs As ADODB.Recordset Dim fld As ADODB.Field Dim lCount As Long Dim sTableName As String getSheetNames = 0 On Error GoTo ERR_GET_SHEET_NAMES Set rs = cn_.OpenSchema(adSchemaTables) lCount = 0 ReDim sSheetNames(lCount) Do Until (rs.EOF) sTableName = rs.Fields("TABLE_NAME").Value If Right$(sTableName, 1) = "$" Then '定義された名前には、"$"が付かない 'オートフィルタや、印刷範囲の指定等により、"_xlnm#"を含む名前が出てくる場合があるので 'それらは無視する '末尾の"$"を除去 sTableName = Left$(sTableName, Len(sTableName) - 1) ReDim Preserve sSheetNames(lCount) sSheetNames(lCount) = sTableName lCount = lCount + 1 End If rs.MoveNext Loop ERR_GET_SHEET_NAMES: If Err.Number <> 0 Then getSheetNames = -Err.Number Else getSheetNames = lCount End If If Not rs Is Nothing Then If rs.State <> adStateClosed Then rs.Close End If Set rs = Nothing End If End Function
呼び出し
Public Sub getTargetSheetNameADO() Dim sTargetPath As String Dim sSheetNames() As String Dim i As Long Dim sgStart As Single Dim sgStop As Single sgStart = Timer 'シート名を取得するファイルのパス sTargetPath = "C:\Datas\大量データ.xlsm" Call connectDB(sTargetPath) Call getSheetNames(sSheetNames) For i = 0 To UBound(sSheetNames) Debug.Print sSheetNames(i) Next i Debug.Print "" Call disconnectDB sgStop = Timer Debug.Print "ADO : " & Format$(sgStop - sgStart, "0.00 sec.") End Sub
呼び出すファイルがマクロありなのは気にしないでください。
ADOを使用しない（Workbooks.Open + For Each）
こっちは、接続とか切断とかないので、いきなり呼び出して処理
Public Sub getTargetSheetNameForEach() Dim wb As Workbook Dim ws As Worksheet Dim sTargetPath As String Dim i As Long Dim sgStart As Single Dim sgStop As Single sgStart = Timer Application.ScreenUpdating = False 'シート名を取得するファイルのパス sTargetPath = "C:\Datas\大量データ.xlsm" Set wb = Workbooks.Open(Filename:=sTargetPath, ReadOnly:=True) Debug.Print " Opend : " & Format$(Timer - sgStart, "0.00 sec.") For Each ws In wb.Worksheets Debug.Print ws.Name Next ws Debug.Print "" wb.Close Set wb = Nothing Application.ScreenUpdating = True sgStop = Timer Debug.Print "ForEach : " & Format$(sgStop - sgStart, "0.00 sec.") End Sub
サンプルデータ１
５０万件のデータが入ったやつ。
ファイルサイズは54MBくらい。
実行結果
call getTargetSheetNameADO Data FilterCondition Key Result Sheet1 総合結果 ADO : 0.09 sec. call getTargetSheetNameForEach Opend : 8.80 sec. Data FilterCondition Key Result 総合結果 Sheet1 ForEach : 9.25 sec.
サンプルデータ２
６万件のデータが入ったやつ。
ファイルサイズは1.1MBくらい。
実行結果
call getTargetSheetNameADO Sheet1 Sheet2 ADO : 0.09 sec. call getTargetSheetNameForEach Opend : 0.77 sec. Sheet1 Sheet2 ForEach : 1.08 sec.
ADOの圧勝
サンプル１の方では、２桁違うよ。
サンプル２でも、１桁違う。
Workbooks.Openがボトルネック。ファイルサイズが大きいほど効いてくる。
ADO OpenSchemaは、ファイルサイズに依存していない。
ちなみに、サンプル１では、Sheet1は非表示になっていますが、どちらも取得できています。
データの並びが違うのがちょっと気になる・・・
最後に
お気軽に取得したいのなら、コードが簡単な
Workbooks.Open + For Each
速度絶対優先なら、コードが面倒くさくても
ADO OpenSchema
となるんでしょうね。
2019/4/8追記
今回の例は、シート名の取得のみの結果です。
ワークシート上のデータを取得するとなると、話は変わってきて、ADOのレコードセットでも、データ数に応じて、それなり（Workbooks.Openと同じくらい？のイメージ？）に時間がかかります。
興味のある人は、ご自分で試してみてください。
エラー発生時の復帰値が統一性がない・・・
Functionにしてるのに復帰値使ってないし・・・
何も考えないでコーディングしてるのがバレバレ
VBAで乱数を使って、意味不明（？）な文字列を生成する・・・コケヲチヰヱタトンシ
いろいろな処理をするコードを書いていると、テスト用の文字列データが欲しくなる時があります。
５個とか１０個位なら適当にキーボードから入力して作ってもいいのですが、数百とか数万とか、それ以上となるととても手入力では無理なので、どこかから探してくるか、あるいは自分で作るかということになります。
内容はどうでもいいから、とにかくデータが欲しいような時には、乱数を使って作ってしまいましょう。
基本的な事
乱数を使用するにあたって、必要なのは、以下の２つです。
Rnd関数
Randomize ステートメント
Rnd関数の使い方は、ここでは省略します。
特定の範囲の整数を生成するには以下のような計算を行います。
Randomize ランダム整数 = Int((最大値 - 最小値 + 1) * Rnd) + 最小値
最大値、最小値のいずれも整数を指定します。
負の数を指定しても大丈夫ですが
最小値<最大値
はmustです。
数字の場合
前述の式を使って取得した値をCStr関数またはFormat関数で文字列変換します。
固定桁数にし、前に０を付けたい場合には、
? Format$(123,String$(7,"0")) 0000123 ? Right$(String$(6,"0") & CStr(123),7) 0000123
こんな感じで出来ます。
注）元データの桁数が指定桁を超えた場合（上の例では７桁）、上記の２例は結果が異なりますので、ご注意ください。
アルファベットの場合
最初の式で得られるのは整数なので、これをアルファベットに変換しなければいけません。
この変換には、Chr関数を使います。
Chr関数には、文字コードを渡しますが、アルファベットの場合、ASCIIコードを指定すればOKです。
ASCIIコードは、こちらで確認できます。
大文字、小文字それぞれの範囲は、以下のようになることがわかります。
| 文字 | 文字コード |
|---|---|
| A | &H41 |
| Z | &H5A |
| a | &H61 |
| z | &h7A |
イミディエイトウィンドウで確認してみると
? Chr(&H41) A ? Chr(&H5A) Z ? Chr(&H61) a ? Chr(&H7A) z
となります。
以上を踏まえて、コードは以下のようになります。
Public Function creaeStringAlpha(ByVal lLength As Long, ByVal useUpperCase As Boolean) As String Dim iBeginCode As Integer Dim iEndCode As Integer Dim sResult As String Dim i As Long If useUpperCase Then iBeginCode = Asc("A") iEndCode = Asc("Z") Else iBeginCode = Asc("a") iEndCode = Asc("z") End If Randomize For i = 1 To lLength sResult = sResult & Chr(Int((iEndCode - iBeginCode + 1) * Rnd) + iBeginCode) Next i creaeStringAlpha = sResult End Function
useUpperCase に Trueを指定すれば大文字で、Falseを指定すれば小文字で生成します。
大小混在としたい場合には、開始コードをAsc("A")、終了コードをAsc("z")とした上で、一旦生成した文字（文字列ではないですよ）が、A～Z、a～zであるかを確認し、OKなら結合、駄目なら再度文字生成し直しというような処理にすればできます。（下記の英数混在を参照）
開始の文字コードと終了の文字コードは&H○○と直接書いてもいいのですが、あとから見て「なんだこれ？」となるのが（私の場合）普通なので、あえてコメント無しでもわかるような書き方をしています。
実行例（イミディエイトウィンドウ）
for i=1 to 5:? creaeStringAlpha(10,True):next YPMLCFTQXW WOIGQGMJCU ODWMWPUGGP UJOWHJNLLM FKPAEYZHKK for i=1 to 5:? creaeStringAlpha(10,false):next rkwqfoyvpr nyzkqsiren hygqzyzlyl djbrscyzxh fpenxaqfrd
英数混在の場合
先程ちょっと出てきた「対象外のコードを除外」をするとこんな感じで出来ます。
ASCIIコードは、
数字 < アルファベット大文字 < アルファベット小文字
なので、
最小文字コードは、数字の最小：Asc("0")
最大文字コードは、アルファベット小文字の最大：Asc("z")
を使用します。
Public Function creaeStringAlphaNum(ByVal lLength As Long) As String Dim iBeginCodeN As Integer Dim iEndCodeN As Integer Dim iBeginCodeAU As Integer Dim iEndCodeAU As Integer Dim iBeginCodeAL As Integer Dim iEndCodeAL As Integer Dim iCode As Integer Dim sResult As String Dim i As Long iBeginCodeN = Asc("0") iEndCodeN = Asc("9") iBeginCodeAU = Asc("A") iEndCodeAU = Asc("Z") iBeginCodeAL = Asc("a") iEndCodeAL = Asc("z") Randomize For i = 1 To lLength Do While True iCode = Int((iEndCodeAL - iBeginCodeN + 1) * Rnd) + iBeginCodeN Select Case iCode Case iBeginCodeN To iEndCodeN Exit Do Case iBeginCodeAU To iEndCodeAU Exit Do Case iBeginCodeAL To iEndCodeAL Exit Do End Select Loop sResult = sResult & Chr(iCode) Next i creaeStringAlphaNum = sResult End Function
実行例（イミディエイトウィンドウ）
for i=1 to 5:? creaeStringAlphaNum(20):next sC2TMIaUKFpJgxGLCjV8 UDnhkqy3OOG6Lk4QdwZC 5AldQ84Ug33RKwTtbIyj W1Wd1iifx2qrJ66IxNp9 Lj31yD74w0In3i8zqEn2
ひらがなの場合
基本的には、アルファベットの時と同じですが、ひらがなの場合文字コードがASCIIコードではなく、ユニコードを使用することになるのでChr関数がChrW関数に、Asc関数がAscW関数を使用することになります。
ユニコードのひらがなは、
こちらを見てください。
VBAでは、一部の文字（&H3094以降の一部）が使用できないため、それらの文字は除外する必要があります。
コードは、
Public Function creaeStringKana(ByVal lLength As Long) As String Dim iBeginCode As Integer Dim iEndCode As Integer Dim sResult As String Dim i As Long '厳密には違うが、VBAで対応できないので、対応可能範囲に限定する iBeginCode = AscW("ぁ") iEndCode = AscW("ん") Randomize For i = 1 To lLength sResult = sResult & ChrW(Int((iEndCode - iBeginCode + 1) * Rnd) + iBeginCode) Next i creaeStringKana = sResult End Function
実行例（イミディエイトウィンドウ）
for i=1 to 5:? creaeStringKana(10):next ふだわんぇよずぽへゎ ろすいらうぱこだぶよ ゎゆめぐほばぽきぴぺ わたのぞらぼづきそあ をむゑろもべぬぶぼよ
カタカナの場合
ひらがなの時と同じですね。コードの範囲が変わるだけです。
文字コードはこちらになります。
コードは、
Public Function creaeStringKatakana(ByVal lLength As Long) As String Dim iBeginCode As Integer Dim iEndCode As Integer Dim sResult As String Dim i As Long '厳密には違うが、VBAで対応できないので、対応可能範囲に限定する iBeginCode = AscW("ァ") iEndCode = AscW("ヶ") Randomize For i = 1 To lLength sResult = sResult & ChrW(Int((iEndCode - iBeginCode + 1) * Rnd) + iBeginCode) Next i creaeStringKatakana = sResult End Function
実行例（イミディエイトウィンドウ）
for i=1 to 5:? creaeStringKatakana(10):next ヶェコゼヂクズザシヤ ゥゼゼキピォンナイベ ヲヒユテビゲネモツノ ズェャヨベリコデグダ コケヲチヰヱタトンシ
"ヰヱ"なんて誰が使うんだよっ！ orz
2019/4/1追記
不連続の多い文字群の場合、キーコードを使用しないで、予め使用可能な文字を配列に１文字ずつ突っ込んで全部結合してから、rndで発生させた乱数で配列のインデックスを指定してもいいのかもしれない全部結合してから、rndで発生させた乱数を使って、midで抜き出してもいいのかもしれない。
これなら、半角、全角混在でも簡単（？）に出来そう。
2019/4/2追記
昨日のアイデアを元に、簡単なパスワード生成関数を作ってみた。
Public Function createPassword(ByVal lLength As Long) As String Const USABLE_CHARS As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#$%(){}" Dim lPos As Long Dim sPassword As String Dim i As Long Randomize For i = 1 To lLength lPos = Int(Len(USABLE_CHARS) * Rnd) + 1 sPassword = sPassword & Mid$(USABLE_CHARS, lPos, 1) Next i createPassword = sPassword End Function
実行結果
for i=1 to 15:? createPassword(10):next lG%wfn9kA7 #VkE0X!xN} pAFE6hQHhK }EhwtPoBEE nZZeeiDYC4 Ivrs96dxq% 0)NsDNg#8v f8JG3rd07o hamu)ojZXd Y%Zwlxh4VT dCgkztKKFK VU6(y!xdfB ba!2Pu6bs4 Wi4ei!Gbc) w{oG{ZZ(ov
指定日が、月内で第何度目の何曜日かを求める（VBA）
最近、表題の処理を２件ほど、はてなブログで見かけた。
いずれの処理も、月始めから指定日までループ処理をしていたが、この手の処理は１週間（７日）の周期性があるので、それを利用してループ処理なしで求めてみた。
thom.hateblo.jp
b004nws862zx.hatenablog.com
抑えておくべきこと
第１の日曜日から土曜日は、毎月１日から７日にある。
第２の日曜日から土曜日は、毎月８日から１５日にある。
以下同様
従って、
| 日 | 週 |
|---|---|
| １～７ | １ |
| ８～１４ | ２ |
| １５～２１ | ３ |
| ２２～２８ | ４ |
| ２９～３１ | ５ |
となる。
７日の周期で、週が１加算されていくので、７で割った商を使えばよい。
ただし、そのまま日を７で割ってしまっては求めたい値（週）は得られない。
7で割って商が1となる整数は、7から13である。そこで1から7を7から13に補正するため、６を加算した上で、７で割ることで目的の値が得られる。
これは商が2以上の場合でも同じである。
コード
Public Function 第N○曜日(ByVal dtTargetDate As Date) As String Const DAY_OF_WEEK As String = "日月火水木金土" Dim lNthWeek As Long Dim sWeek As String '第N lNthWeek = (Day(dtTargetDate) + 6) \ 7 '曜日 sWeek = Mid$(DAY_OF_WEEK, Weekday(dtTargetDate), 1) 第N○曜日 = "第" & CStr(lNthWeek) & sWeek & "曜日" End Function
第何週目の何曜日なのかの場合
基本は上の例と同じ。
違うのは、日に対する補正値。
上の例では、単純に６を加算すればよかったが、この場合には、第１土曜日が１３（７で割って商が１になる最大の整数）になるようにすればよい。
しかし、第１土曜日が何日かによって補正値が変わってくる。
| １日の曜日 | 第１土曜日の日 | 第１土曜日の日を１３にするために必要な値 |
|---|---|---|
| 日 | ７ | ６ |
| 月 | ６ | ７ |
| 火 | ５ | ８ |
| 水 | ４ | ９ |
| 木 | ３ | １０ |
| 金 | ２ | １１ |
| 土 | １ | １２ |
となることから、
第１土曜日の日＋５＋Weekday(１日の日付)
とすることで13を得る事が出来るので、目的の補正値が得られる。
コード
Public Function 第N週の○曜日(ByVal dtTargetDate As Date) As String Const DAY_OF_WEEK As String = "日月火水木金土" Dim dtFirstDate As Date Dim lCorrection As Long Dim lNthWeek As Long Dim sWeek As String '指定日の月の１日 dtFirstDate = DateAdd("d", -Day(dtTargetDate) + 1, dtTargetDate) '第N週計算のための補正値 lCorrection = Weekday(dtFirstDate) + 5 '第N週 lNthWeek = (Day(dtTargetDate) + lCorrection) \ 7 '曜日 sWeek = Mid$(DAY_OF_WEEK, Weekday(dtTargetDate), 1) 第N週の○曜日 = "第" & CStr(lNthWeek) & "週の" & sWeek & "曜日" End Function
実行結果
確認用コード
Public Sub 第○曜日テスト() Dim d As Date For d = #3/1/2019# To #3/31/2019# Debug.Print Format$(d, "yyyy/mm/dd"); Debug.Print vbTab; Debug.Print 第N週の○曜日(d); Debug.Print vbTab; Debug.Print 第N○曜日(d) Next d End Sub
結果
call 第○曜日テスト
2019/03/01 第1週の金曜日 第1金曜日
2019/03/02 第1週の土曜日 第1土曜日
2019/03/03 第2週の日曜日 第1日曜日
2019/03/04 第2週の月曜日 第1月曜日
2019/03/05 第2週の火曜日 第1火曜日
2019/03/06 第2週の水曜日 第1水曜日
2019/03/07 第2週の木曜日 第1木曜日
2019/03/08 第2週の金曜日 第2金曜日
2019/03/09 第2週の土曜日 第2土曜日
2019/03/10 第3週の日曜日 第2日曜日
2019/03/11 第3週の月曜日 第2月曜日
2019/03/12 第3週の火曜日 第2火曜日
2019/03/13 第3週の水曜日 第2水曜日
2019/03/14 第3週の木曜日 第2木曜日
2019/03/15 第3週の金曜日 第3金曜日
2019/03/16 第3週の土曜日 第3土曜日
2019/03/17 第4週の日曜日 第3日曜日
2019/03/18 第4週の月曜日 第3月曜日
2019/03/19 第4週の火曜日 第3火曜日
2019/03/20 第4週の水曜日 第3水曜日
2019/03/21 第4週の木曜日 第3木曜日
2019/03/22 第4週の金曜日 第4金曜日
2019/03/23 第4週の土曜日 第4土曜日
2019/03/24 第5週の日曜日 第4日曜日
2019/03/25 第5週の月曜日 第4月曜日
2019/03/26 第5週の火曜日 第4火曜日
2019/03/27 第5週の水曜日 第4水曜日
2019/03/28 第5週の木曜日 第4木曜日
2019/03/29 第5週の金曜日 第5金曜日
2019/03/30 第5週の土曜日 第5土曜日
2019/03/31 第6週の日曜日 第5日曜日
こちらも参考になります。（かなりオススメ）
www.waenavi.com
