ExcelVBA 　テンプレートコード

::: note warn
自分用のメモなので、形は整ってないです。
:::
### 1次元の配列の要素内で、重複しているものがあるかを調べるFunction。重複有りならTrue、重複無しならFalseをリターン
```
Function IsOverlapping(ByRef arrParam) As Boolean
'1次元の配列の要素内で、重複しているものがあるかを調べる。重複有りならTrue、重複無しならFalseをリターン

  Dim i As Long
  Dim j As Long
  
  IsOverlapping = False  '初期値にFalseを設定
  
  For i = LBound(arrParam) To UBound(arrParam)
    For j = LBound(arrParam) To UBound(arrParam)
      If arrParam(i) = arrParam(j) And i <> j Then
        IsOverlapping = True  '重複があったらTrueに
      End If
      If IsOverlapping Then Exit For  '重複があったらループを抜ける
    Next j
    If IsOverlapping Then Exit For
  Next i

End Function

'整数・文字列・小数のデータで実行可能　文字列はバイナリモード比較
'重複の無い要素数10の配列を最後までチェックする処理を、10万回繰り返して、所要時間1～2秒くらい
```
### フォルダ選択のダイアログを開き、選択されたフォルダのパスを引数で指定されたセルに格納する
```
Private Sub ShowSelectFolderDialog(ByVal lngRow As Long, ByVal lngColumn As Long)
'フォルダ選択のダイアログを開き、選択されたフォルダのパスを引数で指定されたセルに格納する

  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
      Cells(lngRow, lngColumn).Value = .SelectedItems(1) & "\"
    Else
      MsgBox "キャンセルされました"
    End If
  
  End With

End Sub

'Publicプロシージャにして、ボタンから直接呼ぶ形にしてもいいだろう
```
### エクセルファイルを選択するダイアログを開き、選択されたフォルダのパスを引数で指定されたセルに格納する
```
Private Sub ShowSelectExcelFileDialog(ByVal lngRow As Long, ByVal lngColumn As Long)
'エクセルファイルを選択するダイアログを開き、選択されたフォルダのパスを引数で指定されたセルに格納する

  Dim varFileName As Variant
  
  varFileName = Application.GetOpenFilename _
    ("Excel ファイル (*.xls; *.xlsx; *.xlsm; *.xlsb),*.xls; *.xlsx; *.xlsm; *.xlsb")
  
  If VarType(varFileName) = vbBoolean Then
    MsgBox "キャンセルされました"
  Else
    Cells(lngRow, lngColumn).Value = CStr(varFileName)
  End If

End Sub
'Publicプロシージャにして、ボタンから直接呼ぶ形にしてもいいだろう
```
### ブックが既に開かれているかを判定する　　ネットワーク上のブックを誰かがひらいているかも判定できる
```
Public Function IsBookOpened(ByVal bookPath As String) As Boolean

  On Error Resume Next
  
  Open bookPath For Append As #1  '追加モードでブックを開く。実際にブックが開かれるわけではない
  Close #1
  
  If Err.Number <> 0 Then
    IsBookOpened = True
    'エラーが発生していれば、ブックのOpenに失敗している。他のユーザが既に開いていることになる
  Else
    IsBookOpened = False
  End If

End Function
```
### セルのInterior.Color、Font.Colorの数値から16進数文字列(FFAAFF 等)へ変換する
```
※単純にHex関数で変換すると、違う値になるので注意

Function ConvertColorNumberToHex(ByRef ws As Worksheet, ByVal row As Long, _
  ByVal column As Long, ByVal isCellColor As Boolean) As String
  'isCellColorがTrueでセルの背景色、Falseでフォント色
  
  Dim colorNum As Long
  Dim red As Long
  Dim green As Long
  Dim blue As Long
  
  If isCellColor Then  'セルの背景色取得の場合
    colorNum = ws.Cells(row, column).Interior.Color
  Else
    colorNum = ws.Cells(row, column).Font.Color  'フォント色
  End If
  
  red = colorNum Mod 256
  green = Int(colorNum / 256) Mod 256
  blue = Int(colorNum / 256 / 256)
  
  ConvertColorNumberToHex = Right("0" & Hex(red), 2) & Right("0" & Hex(green), 2) & _
    Right("0" & Hex(blue), 2)
End Function
```
### 結合セルを含むセル範囲の、データのある最終行・最終列を求める
```
※結合セルについては、結合範囲の右下のセルを最終セルとする

'*********  結合セルを含むセル範囲の、データのある最終行を求める  *********
'ws             対象となるセルのワークシートオブジェクト
'startColumn    判定をする範囲の最初の列
'endColumn      判定をする範囲の最後の列
Public Function GetLastRowWithMergeCells(ByRef ws As Worksheet, ByVal startColumn As Long, _
  ByVal endColumn As Long) As Long

  Dim mergeRange As Range  '結合している範囲
  Dim i As Long
  Dim lastRow As Long
  Dim tmpNum As Long
  
  lastRow = 1
  For i = startColumn To endColumn
    tmpNum = ws.Cells(ws.Rows.Count, i).End(xlUp).row
    If ws.Cells(tmpNum, i).MergeCells = True Then  '結合しているセルの場合
      Set mergeRange = ws.Cells(tmpNum, i).MergeArea
      tmpNum = mergeRange(mergeRange.Rows.Count, mergeRange.Columns.Count).row
      '結合範囲の右下のセルの行番号を取得
    End If
    If lastRow < tmpNum Then
      lastRow = tmpNum
    End If
  Next i
  GetLastRowWithMergeCells = lastRow
End Function




'*********  結合セルを含むセル範囲の、データのある最終列を求める  *********
'ws             対象となるセルのワークシートオブジェクト
'startRow       判定をする範囲の最初の行
'endRow         判定をする範囲の最後の行
Public Function GetLastColumnWithMergeCells(ByRef ws As Worksheet, ByVal startRow As Long, _
  ByVal endRow As Long) As Long

  Dim mergeRange As Range  '結合している範囲
  Dim i As Long
  Dim lastColumn As Long
  Dim tmpNum As Long
  
  lastColumn = 1
  For i = startRow To endRow
    tmpNum = ws.Cells(i, ws.Columns.Count).End(xlToLeft).column
    If ws.Cells(i, tmpNum).MergeCells = True Then '結合しているセルの場合
      Set mergeRange = ws.Cells(i, tmpNum).MergeArea
      tmpNum = mergeRange(mergeRange.Rows.Count, mergeRange.Columns.Count).column
      '結合範囲の右下のセルの列番号を取得
    End If
    If lastColumn < tmpNum Then
      lastColumn = tmpNum
    End If
  Next i
  GetLastColumnWithMergeCells = lastColumn
End Function
```
### ファイルやフォルダのパスが正しいかどうかをチェックするFunction　　(空白、\で始まる等)
```
'ファイルやフォルダのパスが正しいかどうかをチェックする
'チェックの結果により、以下の整数値をリターン
'0:異常なし
'1:パスが空文字
'2:存在しないパス
'3:「\」で始まるパス
'4:「.」で始まるパス
'5:「/」で始まるパス
'path       フォルダ･ファイルのフルパス
'isFolder   フォルダのパスである場合はTrue、ファイルのパスはFalseを指定する
Public Function ValidateDirectoryPath(ByVal path As String, ByVal isFolder As Boolean) As Long
  ValidateDirectoryPath = 0  '初期値は異常なし
  If path = "" Then
    ValidateDirectoryPath = 1
    Exit Function
  End If
  
  If Left(path, 1) = "\" Then
    ValidateDirectoryPath = 3
    Exit Function
  End If
  If Left(path, 1) = "." Then
    ValidateDirectoryPath = 4
    Exit Function
  End If
  If Left(path, 1) = "/" Then
    ValidateDirectoryPath = 5
    Exit Function
  End If
  
  If isFolder Then  'フォルダのパスである場合
    If xFSO.FolderExists(path) = False Then
      ValidateDirectoryPath = 2
      Exit Function
    End If
  Else
    If xFSO.FileExists(path) = False Then
      ValidateDirectoryPath = 2
      Exit Function
    End If
  End If
End Function
```
### Excelファイルの全シート名を、コンボボックスの要素として格納する例
```
これで完璧かどうかは自信無し

'***********  以下のコードは、フォームのコード内にある

Private Sub btnGetSheetNames_Click()
  Call GetSheetNames
End Sub


Private Sub GetSheetNames()
  'Excelファイルのパスが入っているテキストボックスのコントロール名   txtExcelFilePath
  'シート名のリストを格納するコンボボックスのコントロール名          cmbSheetNames
  
  Dim wb As Workbook
  Dim targetBook As Workbook  'シート名を取得するブック
  Dim ws As Worksheet
  Dim bookPath As String
  Dim isAlreadyOpen As Boolean   'すでに対象となるブックが開かれているか
  
  On Error GoTo GetSheetNames_EH
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  
  Set targetBook = Nothing
  isAlreadyOpen = False
  
  If Me.txtExcelFilePath.Text = "" Then
    MsgBox "「Excelファイルのパス」が空白です"
    Call LastProcess
    Exit Sub
  Else
    bookPath = Me.txtExcelFilePath.Text
  End If
  
  If Dir(bookPath) = "" Then
    MsgBox "「Excelファイルのパス」」で指定されたExcelファイルは存在しません"
    Call LastProcess
    Exit Sub
  End If
  
  For Each wb In Workbooks  '現在開いているブックを走査
    If wb.Path & "\" & wb.Name = bookPath Then
    ' 同パスのものがある場合はすでに開いているので、そのブックを対象にする
      Set targetBook = wb
      isAlreadyOpen = True
      Exit For
    End If
    
    If wb.Name = Dir(bookPath) Then  ' 同名のブックが開かれている場合
      MsgBox "「Excelファイルのパス」」で指定されたExcelファイルと同名のファイルが開かれています" _
        & vbCrLf & "同名のファイルを閉じてからやり直してください"
      Call LastProcess
      Exit Sub
    End If
  Next wb
  
  If targetBook Is Nothing Then  'まだ対象となるブックが開かれていない場合
    Workbooks.Open Filename:=bookPath, UpdateLinks:=0, ReadOnly:=True
    '読み取り専用、リンク更新無しでブックを開く
    Set targetBook = ActiveWorkbook
  End If
  
  Me.cmbSheetNames.Clear  'コンボボックスの全要素をクリア
  For Each ws In targetBook.Worksheets
    Me.cmbSheetNames.AddItem ws.Name
    'シート名を「データのあるシート」のコンボボックスの要素として追加
  Next ws
  
  If isAlreadyOpen = False Then
  'すでに対象となるブックが開かれていた場合は、ブックを閉じない
    targetBook.Close
  End If
  
  
  Call LastProcess
  Exit Sub
 
GetSheetNames_EH:
  MsgBox "エラー発生"
  Call LastProcess
End Sub


Private Sub LastProcess()
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
```
### Windowsのディレクトリ名に使えない文字( \ / : * ? " < > | )が、文字列中に含まれるかを判定する
```
'Windowsのディレクトリに使えない文字が含まれるかを判定する。含まれる場合はTrueをリターン
Private Function existsInvalidString(ByVal pStr As String) As Boolean
  existsInvalidString = False
  
  If InStr(pStr, "\") <> 0 Then
    existsInvalidString = True
    Exit Function
  End If
  If InStr(pStr, "/") <> 0 Then
    existsInvalidString = True
    Exit Function
  End If
  If InStr(pStr, ":") <> 0 Then
    existsInvalidString = True
    Exit Function
  End If
  If InStr(pStr, "*") <> 0 Then
    existsInvalidString = True
    Exit Function
  End If
  If InStr(pStr, "?") <> 0 Then
    existsInvalidString = True
    Exit Function
  End If
  If InStr(pStr, """") <> 0 Then
    existsInvalidString = True
    Exit Function
  End If
  If InStr(pStr, "<") <> 0 Then
    existsInvalidString = True
    Exit Function
  End If
  If InStr(pStr, ">") <> 0 Then
    existsInvalidString = True
    Exit Function
  End If
  If InStr(pStr, "|") <> 0 Then
    existsInvalidString = True
    Exit Function
  End If
End Function



Sub ggg()
'  文字列中に \ / : * ? " < > | が含まれるかを判定

Debug.Print existsInvalidString("\")
Debug.Print existsInvalidString("￥")
Debug.Print existsInvalidString("a \あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("/")
Debug.Print existsInvalidString("／")
Debug.Print existsInvalidString("a /あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString(":")
Debug.Print existsInvalidString("：")
Debug.Print existsInvalidString("a :あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("*")
Debug.Print existsInvalidString("＊")
Debug.Print existsInvalidString("a *あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("?")
Debug.Print existsInvalidString("？")
Debug.Print existsInvalidString("a ?あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("""")
'全角のダブルクォーテーションは指定できない?
Debug.Print existsInvalidString("a ""あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("<")
Debug.Print existsInvalidString("＜")
Debug.Print existsInvalidString("a <あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString(">")
Debug.Print existsInvalidString("＞")
Debug.Print existsInvalidString("a >あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("|")
Debug.Print existsInvalidString("｜")
Debug.Print existsInvalidString("a |あ")

End Sub
```
### サブフォルダまで検索するテンプレート　　再帰を使用
```
Sub SearchSubFolderTemplate()
'サブフォルダまで検索するテンプレート
'「実行」シートには、サブフォルダまで検索するかを選択するチェックボックスがある
'「実行」シートには、フォルダ指定のボタンと実行ボタンがある
  
  Dim folderPath As String
  Dim bolSearchSubFolder As Boolean   'サブフォルダも検索するか

  
  If Cells(3, 2) = "" Then
    MsgBox "フォルダが指定されていません"
    Exit Sub
  Else
    folderPath = Cells(3, 2)
  End If
  
  If Dir(folderPath, vbDirectory) = "" Then
    MsgBox "指定されたフォルダは存在しません"
    Exit Sub
  End If
  
  If Right$(folderPath, 1) <> "\" Then
  'パスの最後に"\"が無い場合は付与する
    folderPath = folderPath & "\"
  End If
  
  bolSearchSubFolder = ThisWorkbook.Worksheets("実行").checkSubFolder.Value
  'サブフォルダまで検索するかを指定
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Call FileSearch(folderPath, bolSearchSubFolder)
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  MsgBox "完了"

End Sub


Sub FileSearch(folderPath As String, bolSearchSubFolder As Boolean)
' ファイル検索を実行する(再帰処理型)

  Dim xFSO As New FileSystemObject
  Dim xFolder As Folder
  Dim xFile As File
    
  If bolSearchSubFolder Then
    For Each xFolder In xFSO.GetFolder(folderPath).SubFolders
    ' サブフォルダを取得する
      Call FileSearch(xFolder.Path, True)
      ' 再帰処理でサブフォルダまで検索
    Next xFolder
  End If
    
  For Each xFile In xFSO.GetFolder(folderPath).Files
  ' ファイルを検索
    If xFile.Name Like "*.xls*" Then   ' エクセル型のファイルの場合
      Debug.Print xFile.Path
    End If
  Next xFile
  
  Set xFSO = Nothing

End Sub


Sub getFolderPath()   'フォルダを選択するダイアログを表示

  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then   ' フォルダが選択された場合
      Cells(3, 2).Value = .SelectedItems(1) & "\"
    Else
      MsgBox "キャンセルされました"
    End If
  End With

End Sub
```
### ユーザーコードを入力するテキストボックスの値の変化に応じて、他のコントロールの表示も変化させる例
```
インポートファイルは、
ExcelVBA関係\インポートファイル\テキストボックスの値の変化でデータの表示も変わるフォームの例
のディレクトリに保存してある



***********  フォームのコード   ****************

Private arrAllUserData() As String
'全てのユーザーデータを取得して格納する arrAllUserData(1 To 4,0)の形式
'1次元 (1)　ユーザーコード
'1次元 (2)　ユーザー名
'1次元 (3)　登録日
'1次元 (4)　所属部署
'2次元は可変長


Private arrSingleUserDataMatchesUserCode(1 To 4) As String
'指定されているユーザーコードに該当するユーザーデータを格納する
'(1)　ユーザーコード
'(2)　ユーザー名
'(3)　登録日
'(4)　所属部署


'フォーム初期化時
Private Sub UserForm_Initialize()
  Erase arrAllUserData
  Erase arrSingleUserDataMatchesUserCode
  ReDim arrAllUserData(1 To 4, 0)  '動的配列はここで初期化したほうがいい
  
  Call GetAllUserData(arrAllUserData)  'ユーザーデータを取得
End Sub


'ユーザーコードのテキストボックスの値が変化した時
Private Sub txtUserCode_Change()

  'テキストボックスに入力されているユーザーコードのデータが存在するかをチェック
  If CheckExistsUserData Then
    Me.lblUserName.Caption = arrSingleUserDataMatchesUserCode(2)
    Me.lblRegisterDate.Caption = arrSingleUserDataMatchesUserCode(3)
    Me.lblPost.Caption = arrSingleUserDataMatchesUserCode(4)
  Else
    Me.lblUserName.Caption = "該当データ無し"
    Me.lblRegisterDate.Caption = "該当データ無し"
    Me.lblPost.Caption = "該当データ無し"
  End If
End Sub


'「実行」ボタンが押された時
Private Sub btnExecute_Click()

  If CheckExistsUserData Then
    MsgBox "処理を開始しました"
  Else
    MsgBox "入力されているユーザーコードに該当するデータは存在しません"
  End If
End Sub



'テキストボックスに入力されているユーザーコードのデータが存在するかをチェック
Private Function CheckExistsUserData() As Boolean
  Dim userCode As String
  Dim reg As Variant
  Dim i As Long

  CheckExistsUserData = False

  Set reg = CreateObject("VBScript.RegExp")

  userCode = Me.txtUserCode.Text  'ユーザーコードを入力するテキストボックス

  With reg
    .Global = True          ' 文字列全体を検索
    .IgnoreCase = False     ' 大文字小文字を区別する
    .Pattern = "^[0-9]{1,4}$"

    If .Test(userCode) = False Then
      Exit Function
    End If
  End With

  Set reg = Nothing

  userCode = Format(CLng(userCode), "0000")  '0000 の形式にする

  Call GetAllUserData(arrAllUserData)  '全てのユーザーデータを取得

  For i = LBound(arrAllUserData, 2) To UBound(arrAllUserData, 2)
    If arrAllUserData(1, i) = userCode Then
      CheckExistsUserData = True
      arrSingleUserDataMatchesUserCode(1) = arrAllUserData(1, i)
      arrSingleUserDataMatchesUserCode(2) = arrAllUserData(2, i)
      arrSingleUserDataMatchesUserCode(3) = arrAllUserData(3, i)
      arrSingleUserDataMatchesUserCode(4) = arrAllUserData(4, i)
      Exit Function
    End If
  Next i
End Function




*************  標準モジュールのコード  **********************

Private Enum SETTING   '定数設定のEnum
  dataStartRow = 3       'ユーザーデータがあるシートのデータ部分が始まる行
  userCodeColumn = 2      'ユーザーコードの列
  userNameColumn = 3      'ユーザー名の列
  registerDateColumn = 4  '登録日の列
  postColumn = 5          '所属部署の列
End Enum


'全てのユーザーデータを取得する。標準モジュールにあるプロシージャ
Public Sub GetAllUserData(ByRef arrAllUserData() As String)
  Dim lastRow As Long
  Dim i As Long

  Erase arrAllUserData
  ReDim arrAllUserData(1 To 4, 0)
  
  lastRow = ユーザーデータ.Cells(ユーザーデータ.Rows.Count, SETTING.userCodeColumn).End(xlUp).Row
  'データ部分オ最後の行番号を取得。"ユーザーデータ"はシートのオブジェクト名
  
  If lastRow < SETTING.dataStartRow Then  'データが全く無い場合
    Exit Sub  '配列は空のまま終了にする
  End If
  
  For i = SETTING.dataStartRow To lastRow
    arrAllUserData(1, UBound(arrAllUserData, 2)) = ユーザーデータ.Cells(i, SETTING.userCodeColumn).Value
    arrAllUserData(2, UBound(arrAllUserData, 2)) = ユーザーデータ.Cells(i, SETTING.userNameColumn).Value
    arrAllUserData(3, UBound(arrAllUserData, 2)) = CStr(ユーザーデータ.Cells(i, SETTING.registerDateColumn).Value)
    arrAllUserData(4, UBound(arrAllUserData, 2)) = ユーザーデータ.Cells(i, SETTING.postColumn).Value
    ReDim Preserve arrAllUserData(1 To 4, UBound(arrAllUserData, 2) + 1)
  Next i
  
  ReDim Preserve arrAllUserData(1 To 4, UBound(arrAllUserData, 2) - 1)  '最後の要素は削除
  
End Sub



Sub ShowUserDataForm()

  Load UserDataForm
  UserDataForm.Show vbModal
End Sub
```