【VBAマクロ】CSVとAccess検索ツール

Excel　VBAマクロでCSVとAccess検索ツールを開発

#検索ツールのレイアウト

####1. CSVファイル検索

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/480807/1767c25b-4a1f-ef49-8330-660e2571b0f0.png)

---

####2. Accessファイル検索
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/480807/fbabec17-8cf3-16ac-f842-fc3f16312675.png)

---

#モジュール説明
|No.|モジュール名| 説明 |
|:--------:|:-------------------|:--------------------------------------------------------------|
| 1        |        CommonUtils |共通モジュール（今回は検索結果タイトル書き込む処理しか記載していない）|
| 2        |          Constants |定数定義モジュール                                               |
| 3        |DataBaseAndCSVUtils |CSVとAccess検索用モジュール                                      |
| 4        |          FileUtils |ファイル操作モジュール                                           |
| 5        |               Main |Main処理モジュール                                               |

---

##1. CommonUtils

```vb:CommonUtils.bas
'###################################### writeTitles ############################################
'
' 結果表示エリアのタイトルを書き込む
'
' 詳細処理： 検索結果のRecordSetのFieldsにより結果表示エリアのタイトルを書き込む
'
' @param   writetosheet    検索結果表示シート
' @param   rownum          検索結果表示開始行（タイトル含む）の行番号
' @param   columnnum       検索結果表示開始列の列番号
' @param   fields          検索結果のRecordSetのFields
'
'################################################################################################
Sub writeTitles(writetosheet As Worksheet, rownum As Integer, columnnum As Integer, fields As ADODB.fields)

  ' 検索結果のRecordSetのFieldsを繰り返し取得用インレータ
  Dim fld As ADODB.Field
  ' 何番目のフィルード記載する変数（0から）、Excelのセルをシフト移動用
  Dim index As Integer
  index = 0
  ' 検索結果のRecordSetのFieldsを繰り返し取得して、結果表示エリアのタイトルを書き込む
  For Each fld In fields
    Dim crtCell As Range
    Set crtCell = writetosheet.Cells(rownum, columnnum + index)
    crtCell.Value = fld.Name
    ' セルのフォントを設定する
    crtCell.Interior.ThemeColor = xlThemeColorAccent5
    crtCell.Borders(xlEdgeTop).LineStyle = xlContinuous
    crtCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
    crtCell.Borders(xlEdgeLeft).LineStyle = xlContinuous
    crtCell.Borders(xlEdgeRight).LineStyle = xlContinuous
    ' インデクスに1を加算する、次回タイトルを書き込む場合、セルを右に一セルシフトする
    index = index + 1
  Next fld
End Sub
```

---

#ソース詳細

##2.Constants

```vb:Constants.bas
Public Const QUERY_TOOL_SHEET_NAME = "SQLツール"     '該当ツールのシート名
Public Const QUERY_SQL_TEXTBOX = "SELECT_SQL"        '検索SQL文の入力テキストボックス
Public Const EXCEL_FILE_PATH = "C:\xxx.csv"          'デフォルトの検索対象CSVファイルのフルパス
Public Const FILE_NAME = "FILE_NAME"                 '検索対象ファイルのフルパス
Public Const RECORD_START_CELL = "RECORD_START_CELL" '結果出力開始セル（タイトル含む）
Public Const ACCESS_FILE_EXTENSION_NAME = "ACCDB"    'Accessファイルの拡張子
```

---

##3.DataBaseAndCSVUtils

```vb:DataBaseAndCSVUtils.bas
'###################################### getAndCheckQuerySQL #####################################
'
' 検索SQL文取得
'
' 詳細処理： 検索SQL文を取得する
'
' @param   sheetName       検索SQL文格納シート
' @param   textboxName     検索SQL文格納テキストボックス
' @param   isOnlyForQuery  Queryチェック--デフォルトはチェックしない
' @param   resultSet       検索結果保存セット
'
' @returen 検索結果総件数（タイトル行含む）
'
'################################################################################################
Public Function getAndCheckQuerySQL(sheetName As String, textboxName As String, Optional isOnlyForQuery As Boolean = False) As String
  Dim ttbSQL As Shape
  Dim result As String
  
  Set ttbSQL = Sheets(sheetName).Shapes(textboxName)
  result = Trim(ttbSQL.TextFrame.Characters.Text)
  If isOnlyForQuery = False Or InStr(UCase(result), "SELECT") = 1 Then
    getAndCheckQuerySQL = result
  End If
  
  Set ttbSQL = Nothing
End Function

'###################################### queryFunction #####################################
'
' 検索処理の入り口
'
' 詳細処理： 検索SQL文により、CSVあるいはAccessファイル内のデータを検索する
'
' @param   fileName       検索対象ファイル
' @param   strSQL         検索SQL文
'
' @returen 検索結果レコードセット
'
'################################################################################################
Function queryFunction(fileName As String, strSQL As String) As ADODB.Recordset

  Dim fso As New FileSystemObject
  
  '拡張子はACCESS_FILE_EXTENSION_NAMEの場合、Access検索処理を行う、その他の場合、CSV検索処理を行う
  If UCase(fso.GetExtensionName(fileName)) = ACCESS_FILE_EXTENSION_NAME Then
    Set queryFunction = queryFromAccess(fileName, strSQL)
  Else
    Set queryFunction = queryFromCSV(fileName, strSQL)
  End If
End Function


'###################################### queryFromCSV #####################################
'
' CSV検索処理
'
' 詳細処理： 検索SQL文により、CSVファイルからデータを検索する
'
' @param   fileName       検索対象ファイル
' @param   strSQL         検索SQL文
'
' @returen 検索結果レコードセット
'
'################################################################################################
Function queryFromCSV(fileName As String, strSQL As String) As ADODB.Recordset

    Dim fso As New FileSystemObject
    Dim fName As String
    Dim fPath As String
    Dim adoCn As New ADODB.Connection
    Dim adoRs As New ADODB.Recordset
    
    'ファイル名とファイルパスを取得します
    fName = fso.GetFileName(fileName)
    fPath = fso.GetParentFolderName(fileName)
    
    Set fso = Nothing
    
    With adoCn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties").Value = "Text;HDR=Yes;FMT=Delimited"
        .Open fPath & "\"
    End With

    'SQLを実行して対象をRecordSetへ
    adoRs.Open strSQL, adoCn
    
    Set queryFromCSV = adoRs
    Set adoCn = Nothing
End Function


'###################################### queryFromAccess #####################################
'
' Access検索処理
'
' 詳細処理： 検索SQL文により、Accessファイルからデータを検索する
'
' @param   fileName       検索対象ファイル
' @param   strSQL         検索SQL文
'
' @returen 検索結果レコードセット
'
'################################################################################################
Function queryFromAccess(acceccFileName As String, strSQL As String) As ADODB.Recordset

    Dim adoCn As New ADODB.Connection
    Dim adoRs As New ADODB.Recordset
   
    'Accessファイルに接続
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & acceccFileName & ";"
    
    'SQLを実行して対象をRecordSetへ
    adoRs.Open strSQL, adoCn

    Set queryFromAccess = adoRs

    Set adoCn = Nothing  'オブジェクトの破棄

End Function
```

---

##4.FileUtils

```vb:FileUtils.bas
'###################################### writeResults ############################################
'
' 検索結果出力
'
' 詳細処理： 検索結果を検索ツールの指定シートの下部分に書き込む
'
' @param   toSheet      検索ツールの指定シート
' @param   startRow     書き込む開始行
' @param   startColumn  書き込む開始列
' @param   resultSet    検索結果保存セット
'
' @returen 検索結果総件数（タイトル行含む）
'
'################################################################################################
Function writeResults(toSheet As Worksheet, startRow As Integer, startColumn As Integer, resultSet As ADODB.Recordset) As Integer

  Dim rowIndex As Integer: rowIndex = 1     ' 行インディクス
  Dim columnIndex As Integer                ' 列インディクス

  ' 検索結果タイトルを書き込む
  Call writeTitles(toSheet, startRow, startColumn, resultSet.fields)
  
  ' 検索結果を行毎に出力する
  Do Until resultSet.EOF
    ' 検索結果の一行のフィルード毎にデータを出力する
    For columnIndex = 0 To resultSet.fields.Count - 1
      Dim currentCell As Range
      Set currentCell = toSheet.Cells(startRow + rowIndex, startColumn + columnIndex)
      currentCell.Value = resultSet.fields(columnIndex).Value
      ' セルのフォーマットを調整する
      currentCell.Borders(xlEdgeTop).LineStyle = xlContinuous
      currentCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
      currentCell.Borders(xlEdgeLeft).LineStyle = xlContinuous
      currentCell.Borders(xlEdgeRight).LineStyle = xlContinuous

    Next columnIndex

    resultSet.MoveNext
    ' 行を下に一行を移動する
    rowIndex = rowIndex + 1
  Loop

  writeResults = rowIndex
End Function
```
---

##5.Main
```vb:Main.bas
'#########################################query########################################################
'
' 検索処理
'
' 処理詳細：「検索」ボタンを押すと、検索SQLにより、データを検索し、検索結果をExcelシートの下部分に出力する
'
'#######################################################################################################
Sub query()
  Dim querySQL                  As String                  ' 検索SQL文保存変数
  Dim queryRecordset            As ADODB.Recordset         ' 検索結果格納セット
  Dim startCell                 As Range                   ' 検索結果出力開始のセル(タイトル含む、左上)
  Dim crtBook                   As Workbook                ' 操作ワークブック
  Dim resultSheet               As Worksheet               ' 検索結果出力ワークシート
  Dim recordStartRow            As Integer                 ' 検索結果出力開始行(タイトル含む)
  Dim recordStartColumn         As Integer                 ' 検索結果出力開始列(タイトル含む)
  Dim rowIndex                  As Integer                 ' 検索結果出力開始行からのカレント行までの差

  Dim sgStart                   As Single: sgStart = Timer ' 処理開始時刻
  Dim sgStop                    As Single                  ' 処理終了時刻
  Dim fileName                  As String                  ' 検索対象ファイル格納変数
  Dim fso                       As New FileSystemObject

  ' 操作ワークブック取得
  Set crtBook = ActiveWorkbook

  ' 検索結果出力ワークシート取得
  Set resultSheet = crtBook.Worksheets(QUERY_TOOL_SHEET_NAME)
  
  ' 検索対象ファイル名取得
  fileName = crtBook.Names(FILE_NAME).RefersToRange.Value
  
  fileName = IIf((fileName = ""), EXCEL_FILE_PATH, fileName)
  
  If Not fso.FileExists(fileName) Then
    MsgBox "読み込みファイルが存在していない、確認ください。", vbCritical
    GoTo EXIT_SUB
  End If

  ' 検索結果出力開始のセル取得
  Set startCell = crtBook.Names(RECORD_START_CELL).RefersToRange

  ' 検索結果出力開始行・列取得
  recordStartRow = startCell.Row
  recordStartColumn = startCell.Column

  ' 検索結果出力エリアクリア
  Call clearResultArea(resultSheet, recordStartRow)

  ' 検索SQL文取得
  querySQL = getAndCheckQuerySQL(QUERY_TOOL_SHEET_NAME, QUERY_SQL_TEXTBOX)

  ' 検索を行う
  Set queryRecordset = queryFunction(fileName, querySQL)

  ' 検索結果出力
  rowIndex = writeResults(resultSheet, recordStartRow, recordStartColumn, queryRecordset)

  ' 処理終了時刻取得
  sgStop = Timer

  ' 処理時間とレコード件数の統計情報を出力する
  resultSheet.Cells(recordStartRow + rowIndex, recordStartColumn).Value = "Done. [ " & Format$(sgStop - sgStart, "0.00") & " sec.][ " & CStr(rowIndex - 1) & " records.]"
  Set queryRecordset = Nothing

EXIT_SUB:
  Set fso = Nothing

End Sub

'#########################################query########################################################
'
' クリア処理
'
' 処理詳細：指定行からワークシートの一番してまでのデータをクリアし、
'           セールの「表示形式」を「標準」に設定する
'
' @param clearSheet  対象ワークシート
' @param startRow    クリア設定開始行（該当行を含む）
'
'
'#######################################################################################################
Sub clearResultArea(clearSheet As Worksheet, startRow As Integer)

    ' クリア開始行取得
    clearSheet.Rows(startRow & ":" & startRow).Select
    
    ' 開始行から一番下まで全て行を選択する
    Range(Selection, Selection.End(xlDown)).Select
    
    ' クリアする
    Selection.ClearContents
    
    ' フォントを設定する
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    ' 表示形式を設定する
    Selection.NumberFormatLocal = "G/標準"
    
    ' 対象ワークシートの一番左上のセルを選択する
    clearSheet.Cells(1, 1).Select
End Sub
```