Util
Attribute VB_Name = "Util" Option Explicit ' --------------------------------------------------------------------------------------------------------------------- ' 定数 ' --------------------------------------------------------------------------------------------------------------------- Public Const TITLE_NAME_PREFIX = "▼" ' --------------------------------------------------------------------------------------------------------------------- ' 変数 ' --------------------------------------------------------------------------------------------------------------------- Dim var開始時刻 As Variant ' ##################################################################################################################### ' # ' # ログ系ユーティリティ ' # ' ##################################################################################################################### Sub log(ByVal strメッセージ As String) Debug.Print Format(Now(), "HH:mm:ss ") & strメッセージ End Sub ' ##################################################################################################################### ' # ' # ステータスバー操作系ユーティリティ ' # ' ##################################################################################################################### ' ********************************************************************************************************************* ' * 機能 :ステータスバーに表示する処理時間を初期化する ' ********************************************************************************************************************* ' Sub init開始時刻() var開始時刻 = Now() End Sub ' ********************************************************************************************************************* ' * 機能 :処理時間の開始時刻を取得する ' ********************************************************************************************************************* ' Function get開始時刻() get開始時刻 = var開始時刻 End Function ' ********************************************************************************************************************* ' * 機能 :処理時間を HH:mm:ss 形式で取得する ' ********************************************************************************************************************* ' Function get処理時刻() get処理時刻 = Format(Now() - var開始時刻, "HH:mm:ss") End Function ' ********************************************************************************************************************* ' * 機能 :ステータスバーに経過時間付でメッセージを表示する ' ********************************************************************************************************************* ' Sub setステータスバー(ByVal strメッセージ As String) If IsEmpty(var開始時刻) Then var開始時刻 = Now() End If Application.StatusBar = get処理時刻() & " " & strメッセージ End Sub ' ##################################################################################################################### ' # ' # ブック、シート操作系ユーティリティ ' # ' ##################################################################################################################### ' ********************************************************************************************************************* ' * 機能 :引数で渡されたシート名以外のシートを削除する ' ********************************************************************************************************************* ' ' Function 不要シート削除(対象ブック情報 As Workbook, ByVal 残すシート名 As String) Dim 前状態 As Boolean 前状態 = Application.DisplayAlerts Application.DisplayAlerts = False Dim ws As Worksheet For Each ws In 対象ブック情報.Worksheets If ws.Name <> 残すシート名 Then Worksheets(ws.Name).Delete End If Next ws Application.DisplayAlerts = 前状態 End Function ' ##################################################################################################################### ' # ' # ダイアログ操作系ユーティリティ ' # ' ##################################################################################################################### ' ********************************************************************************************************************* ' * 機能 :処理続行 or 中止確認ダイアログを表示する ' ********************************************************************************************************************* ' Function 処理続行判断(message As String) Dim rc As VbMsgBoxResult rc = MsgBox(message + Chr(10) + "処理を続行しますか?", vbYesNo, vbQuestion) If rc = vbYes Then MsgBox "処理を続けます", vbInformation Else MsgBox "処理を中止しました。", vbCritical ' マクロの実行中止 End End If ' ********************************************************************************************************************* ' * 機能 :確認ダイアログを表示 ' ********************************************************************************************************************* ' Function 確認ダイアログ表示(messages() As String, Optional ByVal 処理続行確認ダイアログ表示フラグ As Boolean = True) As Long Dim dispMessage, message As Variant For Each message In messages dispMessage = dispMessage + message + Chr(10) Next Dim rc As VbMsgBoxResult rc = MsgBox(dispMessage, vbYesNoCancel + vbQuestion) If rc = vbCancel Then MsgBox "処理を中止しました", vbCritical ' マクロの実行中断 End Else If True = 処理続行確認ダイアログ表示フラグ Then MsgBox "処理を続けます", vbInformation End If End If 確認ダイアログ表示 = rc End Function ' ##################################################################################################################### ' # ' # オートシェイプ操作系ユーティリティ ' # ' ##################################################################################################################### ' ********************************************************************************************************************* ' 機能名:対象シート上にあるオブジェクトおnプロパティを取得する ' 戻り :getShapesProperty as String(2, n) ' (0, n) type ' (1, n) name ' (2, n) TextFrame.Characters.text ' (3, n) Left ' (4, n) Top ' (5, n) Width ' (6, n) Height ' (7, n) TopLeftCell.Address(False, False) ' (8, n) TopLeftCell.row ' (9, n) TopLeftCell.Column ' (10, n) BottomRightCell.Address(False, False) ' (11, n) BottomRightCell.row ' (12, n) BottomRightCell.Column ' ' ********************************************************************************************************************* ' Function getShapesProperty(ByRef targetSheet As Worksheet, Optional ByVal objType As Long = -999, Optional ByVal formCtlType As Long = -999) As Variant Dim ret As Variant Dim i As Long Dim obj As Variant ' 配列の作成。 i = 0 For Each obj In targetSheet.Shapes ' FORMコントロールの場合 If obj.Type = objType Then ' 渡されたフォームコントロールタイプが一致した場合、カウントアップ If obj.FormControlType = formCtlType Then i = i + 1 End If ' 指定なし又は、それ以外のオートシェイプ ElseIf objType = -999 Or obj.Type = objType Then i = i + 1 End If Next ' 対象のオートシェイプがみつかった場合のみ、そのオブジェクトの格納を行う。 If 0 <> i Then ReDim ret(i - 1, 12) ' 配列の作成 i = 0 ' オブジェクト情報の設定 For Each obj In targetSheet.Shapes ' formコントロールの場合 If obj.Type = objType Then ' 渡されたフォームコrントロールタイプが一致した場合、値を取得する。 If obj.FormControlType = formCtlType Then ret(i, 0) = obj.Type ret(i, 1) = obj.AlternativeText ' TextFrameプロパティが使用できない(レイアウト枠がない)オブジェクトは除外 On Error Resume Next ret(i, 2) = obj.ControlFormat.value ret(i, 3) = obj.Left ret(i, 4) = obj.Top ret(i, 5) = obj.Width ret(i, 6) = obj.Height ret(i, 7) = obj.TopLeftCell.Address(False, False) ret(i, 8) = obj.TopLeftCell.Row ret(i, 9) = obj.TopLeftCell.Column ret(i, 10) = obj.Left.BottomRightCell.Address(False, False) ret(i, 11) = obj.Left.BottomRightCell.Row ret(i, 12) = obj.Left.BottomRightCell.Column i = i + 1 End If ' 指定なし又は、それ以外のオートシェイプなどの場合 ElseIf objType = -999 Or obj.Type = objType Then ret(i, 0) = obj.Type ret(i, 1) = obj.AlternativeText ' TextFrameプロパティが使用できない(レイアウト枠がない)オブジェクトは除外 On Error Resume Next ret(i, 2) = obj.TextFrame.Characters.Text ret(i, 3) = obj.Left ret(i, 4) = obj.Top ret(i, 5) = obj.Width ret(i, 6) = obj.Height ret(i, 7) = obj.TopLeftCell.Address(False, False) ret(i, 8) = obj.TopLeftCell.Row ret(i, 9) = obj.TopLeftCell.Column ret(i, 10) = obj.Left.BottomRightCell.Address(False, False) ret(i, 11) = obj.Left.BottomRightCell.Row ret(i, 12) = obj.Left.BottomRightCell.Column i = i + 1 End If Next End If getShapesProperty = ret End Function ' ##################################################################################################################### ' # ' # 配列操作系ユーティリティ ' # ' ##################################################################################################################### ' ********************************************************************************************************************* ' 機能 :引数が配列か判定し、配列の場合は空かどうかも判定する ' 引数 :varArray 配列 ' 戻り値:判定結果(1:配列/0:空の配列/-1:配列じゃない) ' ********************************************************************************************************************* ' Public Function IsArrayEx(varArray As Variant) As Long On Error GoTo ERROR_ If IsArray(varArray) Then IsArrayEx = IIf(UBound(varArray) >= 0, 1, 0) Else IsArrayEx = -1 End If Exit Function ERROR_: If Err.Number = 9 Then IsArrayEx = 0 End If End Function ' ********************************************************************************************************************* ' 機能 :実行結果を保持する二次元配列変数を定義するFunction ' ********************************************************************************************************************* ' Function reDimResult(ByVal topLevelElementSize As Integer, ByRef results() As Variant) Select Case IsArrayEx(results) Case 1 ' resultsが初期化済の場合 ' 現在のレコード数 + 1行領域を確保 ReDim Preserve results(topLevelElementSize, UBound(results, 2) + 1) Case 0 ' resultsが1度も初期化されていない場合 ' 1行領域を確保 ReDim Preserve results(topLevelElementSize, 0) End Select End Function ' ********************************************************************************************************************* ' 機能 :一次元配列に新たな要素を追加する ' ********************************************************************************************************************* ' Function 一次元配列に値を追加(ByRef valueList As Variant, ByVal 追加設定値 As String) ' ファイル名を取得する Select Case IsArrayEx(valueList) Case 1 ReDim Preserve valueList(UBound(valueList) + 1) Case 0 ReDim Preserve valueList(0) End Select ' 追加したリストに、設定値を格納。 valueList(UBound(valueList)) = 追加設定値 End Function ' ********************************************************************************************************************* ' 機能 :二次元配列の行と列を入れ替える ' ********************************************************************************************************************* ' Function 二次元配列行列逆転(ByRef var二次元配列 As Variant) Dim var逆転後配列 As Variant ReDim var逆転後配列( _ LBound(var二次元配列, 2) To UBound(var二次元配列, 2), _ LBound(var二次元配列) To UBound(var二次元配列)) Dim i, j As Long For i = LBound(var二次元配列) To UBound(var二次元配列, 2) For j = LBound(var二次元配列) To UBound(var二次元配列) var逆転後配列(i, j) = var二次元配列(j, i) Next Next 二次元配列行列逆転 = var逆転後配列 End Function ' ##################################################################################################################### ' # ' # 装飾系ユーティリティ ' # ' ##################################################################################################################### ' ********************************************************************************************************************* ' 機能 :対象セルにハイパーリンク数式を適用する ' ********************************************************************************************************************* ' Public Function editHYPERLINK数式( _ ByVal strフォルダ名 As String, _ ByVal strファイル名 As String, _ ByVal strシート名 As String, _ ByVal str座標 As String) As String editHYPERLINK数式 = _ "=HYPERLINK(""[" & strフォルダ名 & "\" & strファイル名 & "]" & _ strシート名 & "!" & str座標 & """,""" & str座標 & """)" End Function ' ********************************************************************************************************************* ' 機能 :対象セル範囲内で検索文字列に該当した文字列を赤太文字にする ' ********************************************************************************************************************* ' Function 検索該当文字の赤太文字化(prmRange As Range, prmTargetString As String) Dim txt As String Dim i, m As Integer Dim targetRange As Range If prmTargetString = "" Then Exit Function End If For Each targetRange In prmRange txt = targetRange.value m = Len(prmTargetString) i = InStr(1, txt, prmTargetString) Do Until i = 0 With prmRange.Characters(i, m) .Font.Bold = True .Font.ColorIndex = 3 End With i = InStr(i + 1, txt, prmTargetString) Loop Next Set targetRange = Nothing End Function ' ##################################################################################################################### ' # ' # シート情報取得系ユーティリティ ' # ' ##################################################################################################################### ' ********************************************************************************************************************* ' 機能 :タイトル名指定でリスト値を取得 ' ※リスト値がなかった場合、配列の要素数1(値は空)が返却されます。 ' ********************************************************************************************************************* ' Function タイトル名指定でリスト値を取得(titleName As String, targetSheet As Worksheet) As Variant Dim targetRangeList As Range Dim targetVariantList As Variant Set targetRangeList = タイトル名指定でリスト値のRange情報を取得(titleName, targetSheet) ' 配列か判定 If targetRangeList.count = 1 Then targetVariantList = Array(targetRangeList.Item(1).value) Else targetVariantList = targetRangeList.value End If タイトル名指定でリスト値を取得 = targetVariantList End Function ' ********************************************************************************************************************* ' 機能 :タイトル名指定でリスト値のRange情報を取得 ' ※リスト値がなかった場合、リスト値エリアの1行目(値は空)のRange情報が返却されます。 ' ********************************************************************************************************************* ' Function タイトル名指定でリスト値のRange情報を取得(titleName As String, targetSheet As Worksheet) As Range ' 検索ヒット数 Dim matchCount As Long Dim checkValue As String ' シート内にタイトル名が複数設定されていない事を確認する。 matchCount = WorksheetFunction.CountIf(targetSheet.UsedRange, titleName) If 1 <> matchCount Then MsgBox "タイトル「" & titleName & "」が複数見つかったため、処理を中断しました。" End End If ' タイトル名のRange情報を取得 Dim FoundCell As Range Set FoundCell = targetSheet.UsedRange.Find(what:=titleName, LookIn:=xlValues, _ LookAt:=xlPart, MatchCase:=False, MatchByte:=False) Dim i, MaxRow, MaxCol As Long ' タイトルに対するリスト値を取得(空白行込み) With targetSheet With .Range(.Cells(FoundCell.Row, FoundCell.Column), .Cells(Rows.count, FoundCell.Column)) MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column End With ' MaxRowを、空白行より一行↑のリスト値の行数に設定する。 For i = 1 To (MaxRow - FoundCell.Row) checkValue = .Cells(FoundCell.Row + i, MaxCol).value If "" = checkValue Or InStr(1, checkValue, TITLE_NAME_PREFIX) > 0 Then If 1 = i Then Call 処理続行判断("タイトル名「" + titleName + "」に対するリスト値が設定されていません。") MaxRow = FoundCell.Row + 1 Else MaxRow = FoundCell.Row + i - 1 End If Exit For End If Next ' リスト値を返却 Set タイトル名指定でリスト値のRange情報を取得 = _ targetSheet.Range(.Cells((FoundCell.Row + 1), FoundCell.Column), .Cells(MaxRow, MaxCol)) End With End Function ' ********************************************************************************************************************* ' 機能 :引数で指定された行が選択状態であるか判定する ' ********************************************************************************************************************* ' Function is選択状態(ByVal lng対象行 As Long) Dim rng As Range For Each rng In Selection.Rows If rng.Row = lng対象行 Then is選択状態 = True Exit Function End If Next rng is選択状態 = False End Function