VBA Utilityクラス


## 検証用
```vb
Option Explicit
'***************************************************************************************************************
'***************************************************************************************************************
Function selectNextSheet()
'■次のシートがあれば選択する
  Dim cntWsNum As Long
  If ActiveSheet.Index + 1 < Worksheets.Count Then
    ActiveSheet.Next.Select
  End If
End Function
'***************************************************************************************************************
Function selectBackSheet()
'■後ろのシートがあれば選択する
  If ActiveSheet.Name <> Worksheets(1).Name Then ActiveSheet.Previous.Select
End Function
'***************************************************************************************************************
Function allSheetsVisible()
'■全ワークシートを表示する
  Dim o As Object
  For Each o In Worksheets
    o.Visible = True
  Next
End Function
'***************************************************************************************************************
Function passControlToSheet()
'■ユーザーフォームからボタン等の押下後、セルにコントロールを移す
'キーボード操作が可能になる
  Dim wds As Window
  Set wds = Windows(1)
  wds.WindowState = xlMinimized
  wds.WindowState = xlMaximized
End Function
'***************************************************************************************************************
Function emancipateCells(Optional wsPassword = "", Optional rowScope As Long = 1000, Optional colScope As String = "ZZ")
'■ウィンドウロック解除と非表示セルの展開
  '展開範囲の指定
  Const rowS = rowScope
  Const colS = colScope
  ActiveSheet.Unprotect Password:=wsPassword
  ActiveWindow.FreezePanes = False
  rowS("1:" & rowScope).Hidden = False
  Columns("A:" & colScope).Hidden = False
End Function
'***************************************************************************************************************
'***************************************************************************************************************
```

## 編集用
```vb
'***************************************************************************************************************
Function geteEndRow(colStr As String,Optional ws As Worksheet) As Long
'指定した列の最も下の行を返す
  Dim ret As Long, rowNum As Long
  'wsを指定しなかった場合はActiveSheetを代入する
  If ws Is Nothing Then Set ws = ActiveSheet
  geteEndRow = ws.Range(colStr & ws.rowS.Count).End(xlUp).row
End Function
'*********************************
Function getEndCol(rowNum As Long, Optional ws As Worksheet) As Long
'指定した行の最左端の列番号を返す
  Dim colNum As Long
  'wsを指定しなかった場合はActiveSheetを代入する
  If ws Is Nothing Then Set ws = ActiveSheet
  getEndCol = Cells(rowNum, Columns.Count).End(xlToLeft).Column
End Function
'***************************************************************************************************************
Public Function getColStr(colNum As Long) As String
'■列番号を渡すと列文字列を返す
  getColStr = Split(Cells(1, colNum).Address, "$")(1)
End Function
'*************************
Public Function getColNum(colStr As String) As Long
'■列文字列から列番号を返す
  getColNum = Cells(1, colStr).Column
End Function
'***************************************************************************************************************
Function getDesktopPath() As String
'■ユーザー環境のデスクトップパスを検出
  Dim wsh As Object
  Set wsh = CreateObject("wscript.shell")
  getDesktopPath = wsh.specialfolders("Desktop")
  Set wsh = Nothing
End Function
'***************************************************************************************************************
Function printSelectedSheets()
'■選択されたシート名を検出
  Dim str As Variant
  For Each str In ActiveWindow.SelectedSheets
    Debug.Print str.Name
  Next
End Function
'***************************************************************************************************************
Sub getFileDataBySQL()
'■指定したエクセルファイルのデータをSQLで取得する
    'ADODBインスタンス作成
    Dim cn As Object
    Dim rs As Object
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    'ADO接続
    cn.Provider = "Microsoft.ACE.OLEDB.12.0" 'Excel2016/2013/2010/2007ブックにADOで接続
    cn.Properties("Extended Properties") = "Excel 12.0" 'Excel2016/2013/2010/2007ブックを表す
    cn.Open ThisWorkbook.Path & "\" & "TestDataBase.xlsx"

    'SQL文の実行
    '上位10件のレコード
    rs.Open "SELECT TOP 10 * FROM [Sheet1$] WHERE 作成日 < #2021/12/07# AND ステータス='済'", cn 
    
    'csvに保存
    Call WriteFileText(rs)

    'メモリの解放
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

Function writeFileText(dt As Object)
'■新規ブックを作成し、データを貼り付けCSVファイルとして保存する

    '新規ブック作成
    Workbooks.Add
    
    '新規ブックにデータ貼り付け
    With Worksheets("Sheet1")
    .UsedRange.ClearContents
    .Range("A1").CopyFromRecordset dt
    End With
    
    '保存するパスの決定
    Dim pathStr As String
    pathStr = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".csv"
    
    '保存
    ActiveWorkbook.SaveAs _
    Filename:=pathStr, _
    FileFormat:=xlCSVUTF8
    
    'ファイルを閉じる
    ActiveWorkbook.Close False

End Function
'***************************************************************************************************************
Function getFileText(fileDir As String, Optional char As String = "UTF-8") As Variant
'■ファイルからテキストデータを抽出する
  ' 【charStr】 に入力可能な値
  '"utf-8" → UTF-8（BOMなし）
  '"utf-16" → UTF-16LE
  '"shift_jis" → CP932（WindowsのShift_JIS）
'https://daitaideit.com/vba-read-output-utf8-no/
  Dim ADO As Object,str As String
  If Dir(fileDir) <> "" Then
    Set ADO = CreateObject("ADODB.Stream")
    With ADO
        .Charset = char
        .Open
        .LoadFromFile fileDir 'ファイルパス
        str = .ReadText '読み込むデータ
        Debug.Print str
        getFileText = str
        .Close
    End With
  End If
  Set ADO = Nothing
End Function
'***************************************************************************************************************
Function writeFileText(savefileDir As String, str As String, Optional charStr As String = "UTF-8")
'■ファイルへ書き込む
  ' 【charStr】 に入力可能な値
  '"utf-8" → UTF-8（BOMなし）
  '"utf-16" → UTF-16LE
  '"shift_jis" → CP932（WindowsのShift_JIS）

    With CreateObject("ADODB.Stream")
        .Charset = charStr
        .Open
        If str <> "" Then .WriteText str '空文字不可
        .SaveToFile savefileDir, 2
        .Close
    End With
End Function

'***************************************************************************************************************

Function getFolderItems(targetDir As String, Optional isFolderName As Boolean = True, Optional isFileName As Boolean = True) As Variant
'■指定したtargetDirのフォルダ、ファイル名を返す。
'戻り値に不要な情報（フォルダ、ファイル名）はfalseを指定する。
  Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
  Dim FolderNames As Object, FolderCount As Long
    Set FolderNames = FSO.GetFolder(targetDir).SubFolders
  Dim FileNames As Object, FileCount As Long
    Set FileNames = FSO.GetFolder(targetDir).Files
  Dim itemList()
  
  FolderCount = FolderNames.Count
  FileCount = FileNames.Count
  
  '要素数確定
  Select Case True
    Case isFolderName = True And isFileName = True
        ReDim itemList(FolderCount + FileCount)
    Case isFolderName = True And isFileName = False
        ReDim itemList(FolderCount)
    Case isFolderName = False And isFileName = True
        ReDim itemList(FileCount)
  End Select
  
  '例外
  Select Case True
    Case isFolderName = False And isFileName = False
      getFolderItems = Array("ParameterException:isFolderName,isFileName:Both Parameters are False")
      Exit Function
    Case FolderCount + FileCount = 0
      getFolderItems = Array("ValueException:Total number of items is 0")
      Exit Function
  End Select
    
  Dim i, tmp
  i = 0
  'フォルダ名をリストへ代入
  If isFolderName = True Then
    For Each tmp In FolderNames
      itemList(i) = tmp.Name
      i = i + 1
    Next
  End If
  
  'ファイル名をリストへ代入
  If isFileName = True Then
    For Each tmp In FileNames
      itemList(i) = tmp.Name
        i = i + 1
    Next
  End If
  
  getFolderItems = itemList
  
End Function
'***************************************************************************************************************
Public Function rActSheetName() As String
'■アクティブシート名を返す
  rActSheetName = ActiveSheet.Name
End Function
'***************************************************************************************************************
Function expandSelectionOfCells(row As Long, col As Long)
'■selectionの拡張
  Dim rCell As Range
  Set rCell = ActiveCell.Resize(row, col)
  rCell.Select
End Function
'***************************************************************************************************************
Function specifiedScrollWindow(pointRow As Long, pointCol As Long)
'■画面スクロール位置の指定
'縦指定
  ActiveWindow.ScrollColumn = pointCol
'横指定
  ActiveWindow.ScrollRow = pointRow
End Function
'***************************************************************************************************************
Function checkValueByRegEx(str As String, pattern As String) As Boolean
'■正規表現で文字列をチェック
'要参照設定 Microsoft VBScript Regular Expressions 5.5
  Dim reg As New RegExp
    With reg
      .IgnoreCase = False
      .pattern = pattern
    End With
  checkValueByRegEx = reg.test(str)
End Function
'***************************************************************************************************************
Function rRemoveRightEndOfStr(str As String, removeLen As Long) As String
'■文字列の右端を指定した長さだけ取り除く
  'strの文字数がrightRemoveLenよりも大きい場合は処理を行う
  If Len(str) >= removeLen Then
    rRemoveRightEndOfStr = Left(str, Len(str) - removeLen)
  Else
    rRemoveRightEndOfStr = "StrException:string shorter than length to remove"
  End If
End Function
'***************************************************************************************************************
Function moveOrCopyRows(originalRow As Long, rowsNum As Long, insertRow As Long, isCopy As Boolean, Optional isFormula As Boolean = False)
'■指定した行の移動またはコピーを行う関数
  '移動元の行
  Dim oRow As Long
  '移動先の行
  Dim iRow As Long
  'formulaで取り出しす際に入れる配列
  ReDim rowsdata(1 To 1, 1 To 1) As Variant
  '列の幅
  Dim columnsCount As Long
  Dim i As Long, j As Long
  oRow = originalRow
  iRow = insertRow
  columnsCount = rowS(insertRow).Columns.Count
  ReDim rowsdata(oRow To oRow + rowsNum - 1, 1 To columnsCount) As Variant
  rowS(oRow & ":" & oRow + rowsNum - 1).Select
  'formula処理
  If isFormula = True Then
    For i = oRow To oRow + rowsNum - 1
      For j = 1 To columnsCount
         rowsdata(i, j) = Cells(i, j).Formula
      Next
    Next
  End If
  '移動か複製かを分岐
  If isCopy = True Then
    Selection.Copy
  Else
    Selection.Cut
  End If
  rowS(iRow & ":" & iRow + rowsNum - 1).Select
  Selection.Insert Shift:=xlDown
  Application.CutCopyMode = False
  If isCopy = True And isFormula = True Then
    Range(Cells(insertRow, 1), Cells(insertRow + rowsNum - 1, columnsCount)) = rowsdata()
  End If
End Function
'***************************************************************************************************************
Function pasteContentsOfArr(upperLeftPosition As Range, arr()) As Variant
'■二次元配列の左上にあたるセルを指定し、中身全部を張り付ける
  Dim setPosRow As Long, setPosCol As Long
  Dim arrRow As Long, arrCol As Long
  setPosRow = upperLeftPosition.row
  setPosCol = upperLeftPosition.Column
  arrRow = UBound(arr, 1)
  arrCol = UBound(arr, 2)
  Range(Cells(setPosRow, setPosCol), Cells(setPosRow + arrRow - 1, setPosCol + arrCol - 1)) = arr
End Function
'***************************************************************************************************************
Function drawColorToCells(targetRange As Range, color As XlRgbColor, Optional otherColor As String = "")
'■指定セルに色を塗る
'色参考URL：https://excel-ubara.com/excelvba4/EXCEL285.html
  Select Case True
    Case color = rgbBlack
      targetRange.Interior.color = RGB(0, 0, 0)
    Case color = rgbRed
      targetRange.Interior.color = RGB(255, 0, 0)
    Case color = rgbBlue
      targetRange.Interior.color = RGB(0, 0, 255)
    Case color = rgbAqua
      targetRange.Interior.color = RGB(0, 255, 255)
    Case color = rgbGreen
      targetRange.Interior.color = RGB(0, 128, 0)
    Case color = rgbYellow
      targetRange.Interior.color = RGB(255, 255, 0)
    Case color = rgbWhite
      targetRange.Interior.color = RGB(255, 255, 255)
    Case Else
      MsgBox ("色定義未設定")
  End Select
End Function
Option Explicit

'***************************************************************************************************************
Function rSheetName(Optional allSheets As Boolean = True) As Variant
'■シート名を配列で返す
'atAllSheets →True:全てのシート/False:選択状態のシート
  Dim sheetNamelist, ws, sheetNameStr As String, i As Long
  
  Select Case allSheets
    Case True
      '全シート
      ReDim sheetNamelist(ActiveWorkbook.Sheets.Count - 1)
      For Each ws In Worksheets
        sheetNamelist(i) = ws.Name
        i = i + 1
      Next
    Case False
      '選択シート
      ReDim sheetNamelist(ActiveWindow.SelectedSheets.Count - 1)
      i = 0
      For Each ws In ActiveWindow.SelectedSheets
        sheetNamelist(i) = ws.Name
        i = i + 1
      Next
  End Select
  
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  '''Debug用

  '''  For Each ws In sheetNamelist
  '''    Debug.Print (ws)
  '''  Next
  
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  rSheetName = sheetNamelist
End Function
'***************************************************************************************************************
Function doActionByKeywordRow(keyword As String, keyCol As String, startRow As Long, endRow As String)
'■キーワードを指定した列の開始行から終了行までの間で探し、見つかれば処理を行う
  Dim i, strNow As String
  For i = startRow To endRow
      strNow = Range(keyCol & i)
      If strNow = keyword Then
        Debug.Print "ここに処理を記述"
      End If
  Next
End Function
'***************************************************************************************************************
Function rTargetCell(Target As String, StartCell As Range, Optional Direction As XlDirection = xlUp, Optional AddWideOfSerch As Long = 0, Optional AddDepthOfSerch As Long = 10) As Range
'■Targetを指定し、条件の範囲で見つかった場合はそのセルの場所、見つからなかった場合はnothingを返す
'Target：ターゲットのキーワード、StartCell：検索開始セル、Direction：検索方向、AddWideOfSerch：検索する幅、AddDepthOfSerch：検索する奥行
  Dim StartCellRow As Long, StartCellCol As Long
  Dim EndCellRow As Long, EndCellCol As Long
  Dim SearchingRange As Range
  Dim w1 As Long, w2 As Long
  Dim i As Long, depthCnt As Long, str, exiFlag As Boolean
  StartCellRow = StartCell.row
  StartCellCol = StartCell.Column
  i = 1
  exiFlag = False
  Select Case Direction
    Case xlUp
      If StartCellRow - AddDepthOfSerch <= 0 Then
        EndCellRow = 2
      Else
        EndCellRow = StartCellRow - AddDepthOfSerch
      End If
      For depthCnt = StartCellRow To EndCellRow Step -1
        If StartCellCol - AddWideOfSerch <= 0 Then
          w1 = 1
        Else
          w1 = StartCellCol - AddWideOfSerch
        End If
        w2 = StartCellCol + AddWideOfSerch
        Set SearchingRange = Range(Cells(StartCellRow - i, w1), Cells(StartCellRow - i, w2))
        SearchingRange.Select
        For Each str In SearchingRange
          Cells(str.row, str.Column).Select
          If Cells(str.row, str.Column) = Target Then
              Set rTargetCell = Cells(str.row, str.Column)
              exiFlag = True
              Exit For
            End If
        Next
        i = i + 1
        If exiFlag = True Then Exit For
      Next
    Case xlDown
        EndCellRow = StartCellRow + AddDepthOfSerch
        For depthCnt = StartCellRow To EndCellRow
          If StartCellCol - AddWideOfSerch <= 0 Then
            w1 = 1
          Else
            w1 = StartCellCol - AddWideOfSerch
          End If
          w2 = StartCellCol + AddWideOfSerch
          Set SearchingRange = Range(Cells(StartCellRow + i, w1), Cells(StartCellRow + i, w2))
          SearchingRange.Select
          For Each str In SearchingRange
            Cells(str.row, str.Column).Select
            If Cells(str.row, str.Column) = Target Then
              Set rTargetCell = Cells(str.row, str.Column)
              exiFlag = True
              Exit For
            End If
          Next
        i = i + 1
        If exiFlag = True Then Exit For
        Next
    Case xlToRight
      EndCellCol = StartCellCol + AddDepthOfSerch
        For depthCnt = StartCellCol To EndCellCol
          If StartCellRow - AddWideOfSerch <= 0 Then
            w1 = 1
          Else
            w1 = StartCellRow - AddWideOfSerch
          End If
          w2 = StartCellRow + AddWideOfSerch
          Set SearchingRange = Range(Cells(w1, StartCellCol + i), Cells(w2, StartCellCol + i))
          SearchingRange.Select
          For Each str In SearchingRange
            Cells(str.row, str.Column).Select
            If Cells(str.row, str.Column) = Target Then
              Set rTargetCell = Cells(str.row, str.Column)
              exiFlag = True
              Exit For
            End If
          Next
        i = i + 1
        If exiFlag = True Then Exit For
        Next
    Case xlToLeft
        If StartCellCol - AddDepthOfSerch <= 0 Then
          EndCellCol = 2
        Else
          EndCellRow = StartCellRow - AddDepthOfSerch
        End If
        For depthCnt = StartCellCol To EndCellCol Step -1
          If StartCellRow - AddWideOfSerch <= 0 Then
            w1 = 1
          Else
            w1 = StartCellRow - AddWideOfSerch
          End If
          w2 = StartCellRow + AddWideOfSerch
          Set SearchingRange = Range(Cells(w1, StartCellCol - i), Cells(w2, StartCellCol - i))
          SearchingRange.Select
          For Each str In SearchingRange
            Cells(str.row, str.Column).Select
            If Cells(str.row, str.Column) = Target Then
              Set rTargetCell = Cells(str.row, str.Column)
              exiFlag = True
              Exit For
            End If
          Next
        i = i + 1
        If exiFlag = True Then Exit For
        Next
  End Select
End Function
'***************************************************************************************************************
'***************************************************************************************************************

```
## 資料作成等


```vb
Function getAllDayOfMonth(targetMonth As Long) As Variant
'■今年の指定した月度の日付全てを配列に入れて返す
  Dim lastDate '最終日
  Dim lastDateNo  '最終日の数
  Dim dayList()
  
  Dim targetYear As Long
  targetYear = Year(Now)
  
  '来月1日の1日前
  lastDate = DateSerial(targetYear, targetMonth + 1, 0)
  lastDateNo = Format(lastDate, "d")
   
   '配列にひと月分の日付データを入れる
  ReDim dayList(lastDateNo - 1)
  Dim i
  For i = 0 To lastDateNo - 1
    dayList(i) = targetYear & "/" & Format(targetMonth, "00") & "/" & Format(1 + i, "00")
  Next
  getAllDayOfMonth = dayList
End Function

'***************************************************************************************************************
'***************************************************************************************************************

```
## 変換

```vb
'***************************************************************************************************************
Function getFormulaValueFromRange(cellsRange As Range) As Variant
'■セル範囲の値をFormulaで二次関数に入れて返す。
'受け側は動的配列で受け取ること：Dim arr()as variant
'例】arr= rFormula(Range範囲) →variantで宣言した動的配列にセル範囲を入れると二次元配列になる
  Dim str As Variant
  Dim strRow As Long
  Dim strCol As Long
  Dim arr As Variant
  Set cellsRange = cellsRange
  ReDim arr(1 To cellsRange.rowS.Count, 1 To cellsRange.Columns.Count)
  For Each str In cellsRange
    strRow = str.row
    strCol = str.Column
    arr(strRow, strCol) = str.Formula
  Next
  getFormulaValueFromRange = arr
End Function
```

## よく使う サンプル

```vb
Sub InsertSelection()
'■選択範囲を特定の場所に挿入 
''例）Worksheets("Sheet1").Range("A5:B18")をRange("A15")にInsert 下方向へずらす。 

  Dim rng As Range
  Set rng = Worksheets("Sheet1").Range("A5:B18")
  
  'コピーorカット
  rng.Copy
  
  '選択箇所へinsert
  'xlShiftToRight(右方向へずらす) , xlShiftDown(下方向へずらす)
  Range("A15").Insert (xlShiftDown)
  
  ' コピーモードを解除
  Application.CutCopyMode = False
End Sub

```
```Sub Sample_SelectionReplace()
'■Selectionを対象に置換処理。例）selectionのAをBに置換
  Dim a As String, b As String
  Range("A5").CurrentRegion.Select
  a = "A"
  b = "B"
  
    '''パラメータ説明
    '''what:=置換前,Replacement:=置換後
    '''LookAt:=xlPart(部分一致),xlWhole(完全一致)
    '''SearchOrder:=xlByRows(列方向優先検索),xlByColumns(行方向優先検索)
    '''MatchCase:=True(大文字と小文字区別),False(区別なし)
    '''MatchByte:=True(全半角区別),False(区別なし)
    '''Selection.Replace What:=a, Replacement:=b, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True, MatchByte:=True
    '''Selection.Replace What:=a, Replacement:=b
  
  Selection.Replace What:=a, Replacement:=b, LookAt:=xlPart, MatchCase:=True, MatchByte:=True
  
End Sub

```
```
Sub Test_InsertStrInCell()
'■ セル内の文字列の、特定の文字列の間に文字列を挿入する
'例）A1の文字列「開始テストテストfinal終了」の
'「final」手前に「TEST」を挿入し、「開始テストテストTESTfinal終了」とする。

  Dim str As String, splitKey As String, strList
  Dim buf

  '文字列定義
  str = Range("A1")
  '区切り文字指定
  splitKey = "final"
  
  '区切り文字を「XXXfinal」に置換し、「XXX」でsplitする
  str = Replace(str, splitKey, "XXX" & splitKey)
  strList = Split(str, "XXX")
  
  '''デバッグ用 >>「開始テストテスト」と「final終了」に分かれる
  ''For Each buf In strList
  ''  Debug.Print buf
  ''Next
  
  '文字列「TEST」を挿入
  Range("A1") = strList(0) & "TEST" & strList(1)
  

End Sub
```
```vb
Sub commandTest()
'■VBAからコマンドプロンプト実行
  Dim obj
  Set obj = CreateObject("WScript.Shell")
  obj.Run "C:\Users\user\Desktop\scpTEST.bat 引数1"  
End Sub
```
## ファイルダイアログ
```vb
' ファイルパス指定用（ファイルがない場合はエラーを吐いてくれる）
Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*,CSVファイル,*.csv")

' 保存パス指定用（ファイルがなくても）
Application.GetSaveAsFilename(FileFilter:="Excelファイル,*.xls*,CSVファイル,*.csv")


Function openFileDialog() As String
'ファイルダイアログを開き、指定したファイルを返す
'return
'OpenFileDir:strng:指定したファイル名（指定しなかった場合は処理終了）

  Dim OpenFileDir As String 'オープンするFileのディレクトリ
  'デフォルトのパスをカレントディレクトリに変更
  ChDir ActiveWorkbook.path
  OpenFileDir = Application.GetOpenFilename("ファイル,*.csv")
  If OpenFileDir = "False" Then End
  
  openFileDialog = OpenFileDir
End Function
'***************************************************************************************************************



```



## ユーザーフォーム
|設定|項目|
|----|----|
|実行中にセルの操作を許可する|showmodel:false||
 

https://qiita.com/YuichiTanaka007/items/d42776b6f3551af7dbe0

## セキュリティリスク によるブロックの解除
セキュリティリスク このファイルのソースが信頼できないため、Microsoft によりマクロの実行がブロックされました。

1. Excelブックを閉じる
2. エクスプローラー上でファイルを右クリック > プロパティ
3. 「全般」タブ > <b>セキュリティ: 「許可する」に☑</b> > 「OK」