Instantly share code, notes, and snippets.
Created
April 23, 2026 04:18
-
Star
0
(0)
You must be signed in to star a gist -
Fork
0
(0)
You must be signed in to fork a gist
-
-
Save YujiFukami/d0c1797db14f72e8445ae294575b10ba to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 'MakeSpinButtonUpDownValue_ShapeName ・・・元場所：IkiAddin.ModRibbonGeneral | |
| 'MakeSpinButtonValueLeftRight_ShapeName・・・元場所：IkiAddin.ModRibbonGeneral | |
| 'Make__SpinButtonValue_ShapeName ・・・元場所：IkiAddin.ModRibbonGeneral | |
| 'GetSelectionCell ・・・元場所：IkiAddin.ModCell | |
| 'OffsetCell ・・・元場所：IkiAddin.ModCell | |
| 'F_InputBox ・・・元場所：IkiAddin.ModMessage | |
| 'MsgYesNo ・・・元場所：IkiAddin.ModMessage | |
| 'GetCellName ・・・元場所：IkiAddin.ModCell | |
| 'AddModuleInBook ・・・元場所：IkiAddin.ModVBIDE | |
| 'AddCodeToModule ・・・元場所：IkiAddin.ModVBIDE | |
| 'GetAllCodeModuleInBook ・・・元場所：IkiAddin.ModVBIDE | |
| Public Sub MakeSpinButtonUpDownValue_ShapeName() | |
| '▲▼のスピンボタンを設置する | |
| '特定セル基準の値一覧から値変化を行う | |
| 'シェイプ名に増減の設定が入力してある | |
| '20260423 | |
| Call Make__SpinButtonValue_ShapeName(True) | |
| End Sub | |
| Public Sub MakeSpinButtonValueLeftRight_ShapeName() | |
| '左右のスピンボタンを設置する | |
| '特定セル基準の値一覧から値変化を行う | |
| 'シェイプ名に増減の設定が入力してある | |
| '20260423 | |
| Call Make__SpinButtonValue_ShapeName(False) | |
| End Sub | |
| Private Sub Make__SpinButtonValue_ShapeName(Opt_UpDown As Boolean) | |
| 'セル範囲にスピンボタンを設置して、選択セルの値を特定のセル基準の一覧をもとに値を変化させる | |
| '20260423 | |
| '選択セル取得 | |
| Dim SelectCell As Range: Set SelectCell = GetSelectionCell | |
| If SelectCell Is Nothing Then Exit Sub | |
| '増減対象のセルを選択 | |
| Dim DefaultCell As Range: Set DefaultCell = OffsetCell(SelectCell(1), 0, -1) | |
| Dim TargetCell As Range: Set TargetCell = F_InputBox("値の変化対象のセルを選択してください", "変化対象セル選択", DefaultCell.Address, , , , , True) | |
| If TargetCell Is Nothing Then Exit Sub | |
| If TargetCell.CountLarge > 1 Then | |
| MsgBox "変化対象のセルは単一セルを選択してください", vbExclamation | |
| Exit Sub | |
| End If | |
| '▲▼ボタンを設置 | |
| Dim Sheet As Worksheet: Set Sheet = SelectCell.Worksheet | |
| Dim ButtonUp As Button | |
| Dim ButtonDown As Button | |
| If Opt_UpDown = True Then 'スピンボタンが上下方向の場合 | |
| ' Set ButtonUp = Sheet.Buttons.Add(SelectCell.Left, SelectCell.Top, SelectCell.Width, SelectCell.Height / 2) | |
| ' Set ButtonDown = Sheet.Buttons.Add(SelectCell.Left, SelectCell.Top + SelectCell.Height / 2, SelectCell.Width, SelectCell.Height / 2) | |
| ' ButtonUp.Text = "▲" | |
| ' ButtonDown.Text = "▼" | |
| '直感的に考えたら逆が良い | |
| Set ButtonUp = Sheet.Buttons.Add(SelectCell.Left, SelectCell.Top + SelectCell.Height / 2, SelectCell.Width, SelectCell.Height / 2) | |
| Set ButtonDown = Sheet.Buttons.Add(SelectCell.Left, SelectCell.Top, SelectCell.Width, SelectCell.Height / 2) | |
| ButtonUp.Text = "▼" | |
| ButtonDown.Text = "▲" | |
| Else | |
| Set ButtonDown = Sheet.Buttons.Add(SelectCell.Left, SelectCell.Top, SelectCell.Width / 2, SelectCell.Height) | |
| Set ButtonUp = Sheet.Buttons.Add(SelectCell.Left + SelectCell.Width / 2, SelectCell.Top, SelectCell.Width / 2, SelectCell.Height) | |
| ButtonUp.Text = ChrW(9654) '右三角形 | |
| ButtonDown.Text = ChrW(9664) '左三角形 | |
| End If | |
| '増減対象のセルを選択 | |
| Dim ListStartCell As Range: Set ListStartCell = F_InputBox("値一覧の基準セルを選択してください", "値一覧基準セル選択", , , , , , True) | |
| If ListStartCell Is Nothing Then Exit Sub | |
| If ListStartCell.CountLarge > 1 Then | |
| MsgBox "値一覧の基準セルは単一セルを選択してください", vbExclamation | |
| Exit Sub | |
| End If | |
| 'ループするかどうかを聞く | |
| Dim Opt_Loop As String | |
| If MsgYesNo("値変化をループしますか?") = True Then | |
| Opt_Loop = "Loop" | |
| Else | |
| Opt_Loop = "NotLoop" | |
| End If | |
| 'ボタンのシェイプ名設定 | |
| Dim CellName As String: CellName = GetCellName(TargetCell) | |
| If CellName = "" Then CellName = TargetCell.Address(False, False) | |
| Dim ListStartCellSheetName As String: ListStartCellSheetName = ListStartCell.Worksheet.Name | |
| Dim ListStartCellName As String: ListStartCellName = GetCellName(ListStartCell) | |
| If ListStartCellName = "" Then ListStartCellName = ListStartCell.Address(False, False) | |
| Dim ShapeName_Up As String: ShapeName_Up = CellName & "_" & "Up_" & ListStartCellSheetName & "_" & ListStartCellName & "_" & Opt_Loop | |
| Dim ShapeName_Down As String: ShapeName_Down = CellName & "_" & "Down_" & ListStartCellSheetName & "_" & ListStartCellName & "_" & Opt_Loop | |
| ButtonUp.Name = ShapeName_Up | |
| ButtonDown.Name = ShapeName_Down | |
| 'コード自動作成 | |
| Dim StrCode As String | |
| Dim Str As String | |
| StrCode = StrCode & "Public Sub ClickSpinButton_Value_OnAction()" & vbLf | |
| StrCode = StrCode & "'疑似スピンボタン（実際はコマンドボタン）から値変化の増減を行う" & vbLf | |
| StrCode = StrCode & "'20260423" & vbLf | |
| StrCode = StrCode & " Call ClickSpinButton_Value" & vbLf | |
| StrCode = StrCode & "End Sub" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'ClickSpinButton_Value ・・・元場所：IkiAddin.ModRibbonGeneral" & vbLf | |
| StrCode = StrCode & "'GetCellByName ・・・元場所：IkiAddin.ModCell" & vbLf | |
| StrCode = StrCode & "'GetSheetByName ・・・元場所：IkiAddin.ModSheet" & vbLf | |
| StrCode = StrCode & "'GetCellArea ・・・元場所：IkiAddin.ModCell" & vbLf | |
| StrCode = StrCode & "'GetEndCol ・・・元場所：IkiAddin.ModCell" & vbLf | |
| StrCode = StrCode & "'GetEndRow ・・・元場所：IkiAddin.ModCell" & vbLf | |
| StrCode = StrCode & "'GetArray2DFromCell ・・・元場所：IkiAddin.ModCell" & vbLf | |
| StrCode = StrCode & "'TransposeN1toArray1D ・・・元場所：IkiAddin.ModArray" & vbLf | |
| StrCode = StrCode & "'IsArray2D ・・・元場所：IkiAddin.ModArray" & vbLf | |
| StrCode = StrCode & "'IsArray2DStart1 ・・・元場所：IkiAddin.ModArray" & vbLf | |
| StrCode = StrCode & "'UniqueArray1D ・・・元場所：IkiAddin.ModArray" & vbLf | |
| StrCode = StrCode & "'IsArray1D ・・・元場所：IkiAddin.ModArray" & vbLf | |
| StrCode = StrCode & "'IsArray1DStart1 ・・・元場所：IkiAddin.ModArray" & vbLf | |
| StrCode = StrCode & "'ConvArray1D_Start1 ・・・元場所：IkiAddin.ModArray" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Sub ClickSpinButton_Value()" & vbLf | |
| StrCode = StrCode & "'疑似スピンボタン（実際はコマンドボタン）から値変化の増減を行う" & vbLf | |
| StrCode = StrCode & "'20260423" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " ''クリックされたボタンから情報取得" & vbLf | |
| StrCode = StrCode & " Dim ShapeName As String: ShapeName = Application.Caller" & vbLf | |
| StrCode = StrCode & " Dim Sheet As Worksheet: Set Sheet = ActiveSheet" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " Dim TmpSplit As Variant: TmpSplit = Split(ShapeName, ""_"")" & vbLf | |
| StrCode = StrCode & " Dim Strcode_CellAddress As String: Strcode_CellAddress = TmpSplit(0) ''増減対象のセル" & vbLf | |
| StrCode = StrCode & " Dim Strcode_UpDown As String: Strcode_UpDown = TmpSplit(1) ''Up or Down" & vbLf | |
| StrCode = StrCode & " Dim Strcode_SheetName As String: Strcode_SheetName = TmpSplit(2) ''値変化の一覧のセルの基準セルのシート名" & vbLf | |
| StrCode = StrCode & " Dim Strcode_ListStartCellAddress As String: Strcode_ListStartCellAddress = TmpSplit(3) ''値変化の一覧のセルの基準セルのアドレス" & vbLf | |
| StrCode = StrCode & " Dim Strcode_Loop As String: Strcode_Loop = TmpSplit(4) ''ループするかどうか" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''''入力する引数に変換" & vbLf | |
| StrCode = StrCode & " Dim Up_True As Boolean" & vbLf | |
| StrCode = StrCode & " Dim MinValue As Double" & vbLf | |
| StrCode = StrCode & " Dim MaxValue As Double" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " If Strcode_UpDown = ""Up"" Then" & vbLf | |
| StrCode = StrCode & " Up_True = True" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " Up_True = False" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''セルの値の増減処理" & vbLf | |
| StrCode = StrCode & " Dim Target As Range: Set Target = GetCellByName(Sheet, Strcode_CellAddress)" & vbLf | |
| StrCode = StrCode & " If Target Is Nothing Then Exit Sub" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " Dim ListSheet As Worksheet: Set ListSheet = GetSheetByName(Sheet.Parent, Strcode_SheetName, False)" & vbLf | |
| StrCode = StrCode & " If ListSheet Is Nothing Then Exit Sub" & vbLf | |
| StrCode = StrCode & " Dim ListStartCell As Range: Set ListStartCell = GetCellByName(ListSheet, Strcode_ListStartCellAddress)" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''一覧取得" & vbLf | |
| StrCode = StrCode & " If ListStartCell.Offset(1, 0).Value = """" Then Exit Sub" & vbLf | |
| StrCode = StrCode & " Dim CellArea As Range: Set CellArea = GetCellArea(ListStartCell, 1, 2) ''Cellを基準にセル範囲を取得" & vbLf | |
| StrCode = StrCode & " Dim List As Variant: List = GetArray2DFromCell(CellArea) ''セル範囲から二次元配列作成" & vbLf | |
| StrCode = StrCode & " List = TransposeN1toArray1D(List) ''Nx1の二次元配列を一次元配列に変換" & vbLf | |
| StrCode = StrCode & " List = UniqueArray1D(List)" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''現在の入力値の位置取得" & vbLf | |
| StrCode = StrCode & " Dim ValueNow As Variant: ValueNow = Target.Value" & vbLf | |
| StrCode = StrCode & " Dim Row As Long: Row = GetNumFromArray1D(ValueNow, List)" & vbLf | |
| StrCode = StrCode & " Dim MaxRow As Long: MaxRow = UBound(List, 1)" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " Dim ValueNext As Variant" & vbLf | |
| StrCode = StrCode & " If Row = 0 Then" & vbLf | |
| StrCode = StrCode & " ValueNext = List(1)" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " If Strcode_UpDown = ""Up"" Then" & vbLf | |
| StrCode = StrCode & " If Row = MaxRow Then" & vbLf | |
| StrCode = StrCode & " If Strcode_Loop = ""Loop"" Then" & vbLf | |
| StrCode = StrCode & " ValueNext = List(1)" & vbLf | |
| StrCode = StrCode & " ElseIf Strcode_Loop = ""NotLoop"" Then" & vbLf | |
| StrCode = StrCode & " ValueNext = List(MaxRow)" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " ValueNext = List(Row + 1)" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " ElseIf Strcode_UpDown = ""Down"" Then" & vbLf | |
| StrCode = StrCode & " If Row = 1 Then" & vbLf | |
| StrCode = StrCode & " If Strcode_Loop = ""Loop"" Then" & vbLf | |
| StrCode = StrCode & " ValueNext = List(MaxRow)" & vbLf | |
| StrCode = StrCode & " ElseIf Strcode_Loop = ""NotLoop"" Then" & vbLf | |
| StrCode = StrCode & " ValueNext = List(1)" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " ValueNext = List(Row - 1)" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " Target.Value = ValueNext" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "End Sub" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function GetCellByName(ByRef Sheet As Worksheet, _" & vbLf | |
| StrCode = StrCode & " ByRef Name As String) _" & vbLf | |
| StrCode = StrCode & " As Range" & vbLf | |
| StrCode = StrCode & "'名前定義よりそのシートにおけるセルを取得する" & vbLf | |
| StrCode = StrCode & "'シート内にその名前のセルが無かったらNothingを返す" & vbLf | |
| StrCode = StrCode & "'20230629" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'Sheet・・・シート名" & vbLf | |
| StrCode = StrCode & "'Name ・・・セルの名前定義" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " Dim Output As Range" & vbLf | |
| StrCode = StrCode & " On Error Resume Next" & vbLf | |
| StrCode = StrCode & " Set Output = Sheet.Range(Name)" & vbLf | |
| StrCode = StrCode & " On Error GoTo 0" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " Set GetCellByName = Output" & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function GetSheetByName(ByRef Book As Workbook, _" & vbLf | |
| StrCode = StrCode & " ByRef SheetName As String, _" & vbLf | |
| StrCode = StrCode & " Optional ByRef Message As Boolean = True) _" & vbLf | |
| StrCode = StrCode & " As Worksheet" & vbLf | |
| StrCode = StrCode & "'指定名前のシートを取得する" & vbLf | |
| StrCode = StrCode & "'指定したシート名の存在を確認して、ない場合の警告を表示する。" & vbLf | |
| StrCode = StrCode & "'20210728" & vbLf | |
| StrCode = StrCode & "'20220812 改良(メッセージを表示するか選択可能に)" & vbLf | |
| StrCode = StrCode & "'紹介予定" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'Book ・・・対象のワークブック" & vbLf | |
| StrCode = StrCode & "'SheetName・・・探索するシート名" & vbLf | |
| StrCode = StrCode & "'[Message]・・・警告メッセージを表示するかどうか" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " Dim Output As Worksheet" & vbLf | |
| StrCode = StrCode & " On Error Resume Next" & vbLf | |
| StrCode = StrCode & " Set Output = Book.Sheets(SheetName)" & vbLf | |
| StrCode = StrCode & " On Error GoTo 0" & vbLf | |
| StrCode = StrCode & " If Output Is Nothing Then" & vbLf | |
| StrCode = StrCode & " If Message = True Then" & vbLf | |
| StrCode = StrCode & " MsgBox ""シート名「"" & SheetName & ""」が見つかりません"" & vbLf & ""処理を終了します"", vbExclamation" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Exit Function" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " Set GetSheetByName = Output" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function GetCellArea(ByVal StartCell As Range, _" & vbLf | |
| StrCode = StrCode & " Optional ByRef ColCount As Long, _" & vbLf | |
| StrCode = StrCode & " Optional ByRef StartRow As Long = 1, _" & vbLf | |
| StrCode = StrCode & " Optional ByRef MaxBlankCount As Long = 0) _" & vbLf | |
| StrCode = StrCode & " As Range" & vbLf | |
| StrCode = StrCode & "'基準位置のセルだけから表範囲セルを取得する。" & vbLf | |
| StrCode = StrCode & "'非表示セル、フィルターも全て考慮した処理" & vbLf | |
| StrCode = StrCode & "'20220221" & vbLf | |
| StrCode = StrCode & "'20221121 MaxBlankCountを入力可能に" & vbLf | |
| StrCode = StrCode & "'20240524 GetEndColのMaxBlankCountはデフォルトの100を使用する" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/getcellarea" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'StartCell ・・・基準セル" & vbLf | |
| StrCode = StrCode & "'[ColCount] ・・・セル範囲の列数(省略なら基準セルから自動で探索)" & vbLf | |
| StrCode = StrCode & "'[StartRow] ・・・セル範囲の範囲内での開始行番号" & vbLf | |
| StrCode = StrCode & "' 省略なら1で最初の行からの範囲。" & vbLf | |
| StrCode = StrCode & "' ヘッダー行など1行目の項目行を省きたい場合は2" & vbLf | |
| StrCode = StrCode & "'[MaxBlankCount]・・・最終行判定用の空白セルの連続個数" & vbLf | |
| StrCode = StrCode & "' 指定個数の空白セルが連続したら最後の非空白セルが最終セル" & vbLf | |
| StrCode = StrCode & "' 人為的に非表示行の存在があり得る場合は0以外にする(滅多にない)" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " ''最終列番号を計算" & vbLf | |
| StrCode = StrCode & " Dim EndCol As Long ''最終列番号" & vbLf | |
| StrCode = StrCode & " If ColCount = 0 Then ''列数が指定されていない" & vbLf | |
| StrCode = StrCode & " ''探索" & vbLf | |
| StrCode = StrCode & " EndCol = GetEndCol(StartCell)" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " ''指定列数から計算" & vbLf | |
| StrCode = StrCode & " EndCol = StartCell.Column + ColCount - 1" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''最終行番号計算" & vbLf | |
| StrCode = StrCode & " Dim EndRow As Long ''最終行番号" & vbLf | |
| StrCode = StrCode & " EndRow = GetEndRow(StartCell, MaxBlankCount) ''探索" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''開始セル、終了セルを計算" & vbLf | |
| StrCode = StrCode & " Dim Sheet As Worksheet: Set Sheet = StartCell.Worksheet" & vbLf | |
| StrCode = StrCode & " Set StartCell = StartCell.Offset(StartRow - 1, 0)" & vbLf | |
| StrCode = StrCode & " Dim EndCell As Range: Set EndCell = Sheet.Cells(EndRow, EndCol)" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " Dim Output As Range: Set Output = Range(StartCell, EndCell)" & vbLf | |
| StrCode = StrCode & " Set GetCellArea = Output" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function GetEndCol(ByRef StartCell As Range, _" & vbLf | |
| StrCode = StrCode & " Optional ByVal MaxBlankCount As Long = 100) _" & vbLf | |
| StrCode = StrCode & " As Long" & vbLf | |
| StrCode = StrCode & "'指定セルから右方向の最終セルの列番号を取得する" & vbLf | |
| StrCode = StrCode & "'非表示列があることを考慮してRange.Endは使用しない" & vbLf | |
| StrCode = StrCode & "'20211102" & vbLf | |
| StrCode = StrCode & "'20220221 連続空白個数の判定式を修正" & vbLf | |
| StrCode = StrCode & "'20220301 改良" & vbLf | |
| StrCode = StrCode & "'20240524 MaxBlankCountはデフォルトで100にする" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/getendcol" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'StartCell ・・・探索する基準の開始セル" & vbLf | |
| StrCode = StrCode & "'[MaxBlankCount]・・・最終列判定用の空白セルの連続個数" & vbLf | |
| StrCode = StrCode & "' 指定個数の空白セルが連続したら最後の非空白セルが最終セル" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''処理" & vbLf | |
| StrCode = StrCode & " Dim Sheet As Worksheet: Set Sheet = StartCell.Worksheet" & vbLf | |
| StrCode = StrCode & " Dim StartRow As Long: StartRow = StartCell.Row" & vbLf | |
| StrCode = StrCode & " Dim StartCol As Long: StartCol = StartCell.Column" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " Dim TmpBlankCount As Long" & vbLf | |
| StrCode = StrCode & " Dim TmpEndCol As Long" & vbLf | |
| StrCode = StrCode & " Dim TmpCol As Long" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " For TmpCol = StartCol To Sheet.Columns.Count" & vbLf | |
| StrCode = StrCode & " If Sheet.Cells(StartRow, TmpCol).Value = """" Then" & vbLf | |
| StrCode = StrCode & " ''次の右側のセルが空白の場合" & vbLf | |
| StrCode = StrCode & " If MaxBlankCount = 0 Then" & vbLf | |
| StrCode = StrCode & " ''その位置の手前が最終行" & vbLf | |
| StrCode = StrCode & " Exit For" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " ''連続する空白セル個数加算" & vbLf | |
| StrCode = StrCode & " TmpBlankCount = TmpBlankCount + 1" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " If TmpBlankCount >= MaxBlankCount Then" & vbLf | |
| StrCode = StrCode & " ''指定した数以上に空白セルが連続した場合は" & vbLf | |
| StrCode = StrCode & " ''最後の非空白セルが最終行" & vbLf | |
| StrCode = StrCode & " Exit For" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " ''次の右側のセルが非空白の場合" & vbLf | |
| StrCode = StrCode & " TmpEndCol = TmpCol" & vbLf | |
| StrCode = StrCode & " TmpBlankCount = 0" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Next" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " If TmpEndCol = 0 Then" & vbLf | |
| StrCode = StrCode & " ''右側がずっと空白セルの場合" & vbLf | |
| StrCode = StrCode & " TmpEndCol = StartCell.Column" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " GetEndCol = TmpEndCol" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function GetEndRow(ByRef StartCell As Range, _" & vbLf | |
| StrCode = StrCode & " Optional ByVal MaxBlankCount As Long = 0) _" & vbLf | |
| StrCode = StrCode & " As Long" & vbLf | |
| StrCode = StrCode & "'指定セル基準に最終行番号の取得" & vbLf | |
| StrCode = StrCode & "'オートフィルタが設定してある場合も考慮する" & vbLf | |
| StrCode = StrCode & "'20210728" & vbLf | |
| StrCode = StrCode & "'20220221 連続空白個数の判定式を修正" & vbLf | |
| StrCode = StrCode & "'20250127 出力される値は1以上にする" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/getendrow" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'StartCell ・・・探索する基準の開始セル" & vbLf | |
| StrCode = StrCode & "'[MaxBlankCount]・・・最終行判定用の空白セルの連続個数" & vbLf | |
| StrCode = StrCode & "' 指定個数の空白セルが連続したら最後の非空白セルが最終セル" & vbLf | |
| StrCode = StrCode & "' 人為的に非表示行の存在があり得る場合は0以外にする(滅多にない)" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''処理" & vbLf | |
| StrCode = StrCode & " Dim Sheet As Worksheet: Set Sheet = StartCell.Worksheet" & vbLf | |
| StrCode = StrCode & " Dim StartRow As Long" & vbLf | |
| StrCode = StrCode & " Dim StartCol As Long" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " Dim TmpBlankCount As Long" & vbLf | |
| StrCode = StrCode & " Dim TmpEndRow As Long" & vbLf | |
| StrCode = StrCode & " Dim TmpRow As Long" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " If Sheet.AutoFilterMode = True Or MaxBlankCount <> 0 Then" & vbLf | |
| StrCode = StrCode & " ''オートフィルタが設定されている場合 ⇒ Range.Endプロパティは使えないパターン" & vbLf | |
| StrCode = StrCode & " ''もしくは、連続空白セル個数が指定してある場合 ⇒ Range.Endプロパティを使わないと決めた場合" & vbLf | |
| StrCode = StrCode & " ''→愚直に空白セルを1つずつ数える" & vbLf | |
| StrCode = StrCode & " StartRow = StartCell.Row" & vbLf | |
| StrCode = StrCode & " StartCol = StartCell.Column" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " For TmpRow = StartRow To Sheet.Rows.Count ''シート下端行まで探索" & vbLf | |
| StrCode = StrCode & " If IsError(Sheet.Cells(TmpRow, StartCol).Value) = True Then" & vbLf | |
| StrCode = StrCode & " If MaxBlankCount = 0 Then" & vbLf | |
| StrCode = StrCode & " ''その位置の手前が最終行" & vbLf | |
| StrCode = StrCode & " Exit For" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " TmpBlankCount = TmpBlankCount + 1" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " If TmpBlankCount >= MaxBlankCount Then ''20220221" & vbLf | |
| StrCode = StrCode & " ''指定した数以上に空白セルが連続した場合は、最後の非空白セルが最終行" & vbLf | |
| StrCode = StrCode & " Exit For" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " ElseIf Sheet.Cells(TmpRow, StartCol).Value = """" Then" & vbLf | |
| StrCode = StrCode & " If MaxBlankCount = 0 Then" & vbLf | |
| StrCode = StrCode & " ''その位置の手前が最終行" & vbLf | |
| StrCode = StrCode & " Exit For" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " ''連続する空白セル個数加算" & vbLf | |
| StrCode = StrCode & " TmpBlankCount = TmpBlankCount + 1" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " If TmpBlankCount >= MaxBlankCount Then" & vbLf | |
| StrCode = StrCode & " ''指定した数以上に空白セルが連続した場合" & vbLf | |
| StrCode = StrCode & " ''最後の非空白セルが最終行" & vbLf | |
| StrCode = StrCode & " Exit For" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " TmpEndRow = TmpRow" & vbLf | |
| StrCode = StrCode & " TmpBlankCount = 0" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Next" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " TmpEndRow = WorksheetFunction.Max(1, TmpEndRow) ''必ず1以上にする" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " ''オートフィルタが設定されていない場合" & vbLf | |
| StrCode = StrCode & " ''→Range.Endを利用した最終行の取得" & vbLf | |
| StrCode = StrCode & " TmpEndRow = Sheet.Cells(Sheet.Rows.Count, StartCell.Column).End(xlUp).Row" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " GetEndRow = TmpEndRow" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function GetArray2DFromCell(ByRef CellArea As Range) _" & vbLf | |
| StrCode = StrCode & " As Variant" & vbLf | |
| StrCode = StrCode & "'セルオブジェクトからセル値の二次元配列を取得する" & vbLf | |
| StrCode = StrCode & "'セルオブジェクトが単一セルでも二次元配列となる。" & vbLf | |
| StrCode = StrCode & "'「単一セル.Value」が配列でなく変数になるのに対応" & vbLf | |
| StrCode = StrCode & "'20220921" & vbLf | |
| StrCode = StrCode & "'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/35185051.html" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'CellArea・・・セル範囲" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'戻り値" & vbLf | |
| StrCode = StrCode & "'セル範囲から生成される二次元配列" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " Dim Output As Variant" & vbLf | |
| StrCode = StrCode & " If CellArea.CountLarge = 1 Then ''単一セルの場合" & vbLf | |
| StrCode = StrCode & " ReDim Output(1 To 1, 1 To 1)" & vbLf | |
| StrCode = StrCode & " Output(1, 1) = CellArea.Value" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " Output = CellArea.Value" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " GetArray2DFromCell = Output" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function TransposeN1toArray1D(Array2D_N1 As Variant) As Variant" & vbLf | |
| StrCode = StrCode & "'要素数Nx1(縦一列)の二次元配列を転移して一次元配列にする" & vbLf | |
| StrCode = StrCode & "'各要素がオブジェクトでも対応可能" & vbLf | |
| StrCode = StrCode & "'通常のWorksheetFunction.Transposeだと日付型が文字列型になる問題対応" & vbLf | |
| StrCode = StrCode & "'20220921" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/transposen1toarray1d" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''引数チェック" & vbLf | |
| StrCode = StrCode & " If IsArray2D(Array2D_N1, ""Array2D_N1"") = False Then Exit Function" & vbLf | |
| StrCode = StrCode & " If IsArray2DStart1(Array2D_N1, ""Array2D_N1"") = False Then Exit Function" & vbLf | |
| StrCode = StrCode & " If UBound(Array2D_N1, 2) <> 1 Then" & vbLf | |
| StrCode = StrCode & " MsgBox ""横要素数は1にしてください"", vbExclamation" & vbLf | |
| StrCode = StrCode & " Stop" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''処理" & vbLf | |
| StrCode = StrCode & " Dim I As Long" & vbLf | |
| StrCode = StrCode & " Dim N As Long: N = UBound(Array2D_N1, 1) ''縦要素数" & vbLf | |
| StrCode = StrCode & " Dim Output As Variant: ReDim Output(1 To N) ''出力する配列の準備" & vbLf | |
| StrCode = StrCode & " For I = 1 To N" & vbLf | |
| StrCode = StrCode & " If IsObject(Array2D_N1(I, 1)) = True Then ''要素がオブジェクトの場合" & vbLf | |
| StrCode = StrCode & " Set Output(I) = Array2D_N1(I, 1) ''オブジェクトを格納" & vbLf | |
| StrCode = StrCode & " Else ''変数の場合" & vbLf | |
| StrCode = StrCode & " Output(I) = Array2D_N1(I, 1) ''変数で格納" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Next" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " TransposeN1toArray1D = Output" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function IsArray2D(ByRef Array2D As Variant, _" & vbLf | |
| StrCode = StrCode & " Optional ByRef ArrayName As String = ""Array2D"") _" & vbLf | |
| StrCode = StrCode & " As Boolean" & vbLf | |
| StrCode = StrCode & "'入力配列が二次元配列かどうかチェックする" & vbLf | |
| StrCode = StrCode & "'20210804" & vbLf | |
| StrCode = StrCode & "'20220309 変数名変更" & vbLf | |
| StrCode = StrCode & "'20241230 Functionプロシージャにして判定結果を返す" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/isarray1d" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'Array2D ・・・チェックする配列" & vbLf | |
| StrCode = StrCode & "'[ArrayName]・・・エラーメッセージで表示する時の名前" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " On Error Resume Next" & vbLf | |
| StrCode = StrCode & " Dim Dummy2 As Long: Dummy2 = UBound(Array2D, 2)" & vbLf | |
| StrCode = StrCode & " Dim Dummy3 As Long: Dummy3 = UBound(Array2D, 3)" & vbLf | |
| StrCode = StrCode & " On Error GoTo 0" & vbLf | |
| StrCode = StrCode & " If Dummy2 = 0 Or Dummy3 <> 0 Then" & vbLf | |
| StrCode = StrCode & " MsgBox ArrayName & ""は二次元配列を入力してください"", vbExclamation" & vbLf | |
| StrCode = StrCode & " Stop ''エラーを確認するために一度停止する" & vbLf | |
| StrCode = StrCode & " Exit Function ''Falseが返ってくる" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " IsArray2D = True" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function IsArray2DStart1(ByRef Array2D As Variant, _" & vbLf | |
| StrCode = StrCode & " Optional ByRef ArrayName As String = ""Array2D"") _" & vbLf | |
| StrCode = StrCode & " As Boolean" & vbLf | |
| StrCode = StrCode & "'入力二次元配列の開始番号が1かどうかチェックする" & vbLf | |
| StrCode = StrCode & "'20210804" & vbLf | |
| StrCode = StrCode & "'20220309 変数名変更" & vbLf | |
| StrCode = StrCode & "'20241230 Functionプロシージャにして判定結果を返す" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/isarray1d" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'Array2D ・・・チェックする二次元配列" & vbLf | |
| StrCode = StrCode & "'[ArrayName]・・・エラーメッセージで表示する時の名前" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " If LBound(Array2D, 1) <> 1 Or LBound(Array2D, 2) <> 1 Then" & vbLf | |
| StrCode = StrCode & " MsgBox ArrayName & ""の開始要素番号は1にしてください"", vbExclamation" & vbLf | |
| StrCode = StrCode & " Stop ''エラーを確認するために一度停止する" & vbLf | |
| StrCode = StrCode & " Exit Function ''Falseが返ってくる" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " IsArray2DStart1 = True" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function UniqueArray1D(Array1D As Variant) As Variant" & vbLf | |
| StrCode = StrCode & "'一次元配列のユニーク値を一次元配列で返す" & vbLf | |
| StrCode = StrCode & "'20211102" & vbLf | |
| StrCode = StrCode & "'20221027変更" & vbLf | |
| StrCode = StrCode & "'20260210 Array1DがEmptyの場合の例外処理追加" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/uniquearray1d" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'Array1D・・・一次元配列" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "'返り値" & vbLf | |
| StrCode = StrCode & "'一次元配列のユニーク値の一次元配列" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " If IsEmpty(Array1D) = True Then Exit Function ''20260210追加" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " ''引数チェック" & vbLf | |
| StrCode = StrCode & " If IsArray1D(Array1D) = False Then Exit Function" & vbLf | |
| StrCode = StrCode & " If IsArray1DStart1(Array1D) = False Then Exit Function" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''処理" & vbLf | |
| StrCode = StrCode & " ''ユニーク値抜き出し用に連想配列を定義" & vbLf | |
| StrCode = StrCode & " Dim TmpDict As Object: Set TmpDict = CreateObject(""Scripting.Dictionary"")" & vbLf | |
| StrCode = StrCode & " Dim TmpValue As Variant" & vbLf | |
| StrCode = StrCode & " Dim I As Long" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''ユニーク値だけを連想配列に格納する" & vbLf | |
| StrCode = StrCode & " For I = 1 To UBound(Array1D, 1)" & vbLf | |
| StrCode = StrCode & " TmpValue = Array1D(I)" & vbLf | |
| StrCode = StrCode & " If TmpDict.Exists(TmpValue) = False Then" & vbLf | |
| StrCode = StrCode & " TmpDict.Add TmpValue, """"" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Next I" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力する一次元配列を作成" & vbLf | |
| StrCode = StrCode & " Dim Output As Variant: Output = TmpDict.Keys" & vbLf | |
| StrCode = StrCode & "' Output = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Output))''20221027変更(要素数が多いと勝手に要素数が減る)" & vbLf | |
| StrCode = StrCode & " Output = ConvArray1D_Start1(Output)" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " UniqueArray1D = Output" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function IsArray1D(ByRef Array1D As Variant, _" & vbLf | |
| StrCode = StrCode & " Optional ByRef ArrayName As String = ""Array1D"") _" & vbLf | |
| StrCode = StrCode & " As Boolean" & vbLf | |
| StrCode = StrCode & "'入力配列が一次元配列かどうかチェックする" & vbLf | |
| StrCode = StrCode & "'20210804" & vbLf | |
| StrCode = StrCode & "'20220309 変数名変更" & vbLf | |
| StrCode = StrCode & "'20241230 Functionプロシージャにして判定結果を返す" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/isarray1d" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'Array1D ・・・チェックする配列" & vbLf | |
| StrCode = StrCode & "'[ArrayName]・・・エラーメッセージで表示する時の名前" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " On Error Resume Next" & vbLf | |
| StrCode = StrCode & " Dim Dummy As Long: Dummy = UBound(Array1D, 2)" & vbLf | |
| StrCode = StrCode & " On Error GoTo 0" & vbLf | |
| StrCode = StrCode & " If Dummy <> 0 Then" & vbLf | |
| StrCode = StrCode & " MsgBox ArrayName & ""は一次元配列を入力してください"", vbExclamation" & vbLf | |
| StrCode = StrCode & " Stop ''エラーを確認するために一度停止する" & vbLf | |
| StrCode = StrCode & " Exit Function ''Falseが返ってくる" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " IsArray1D = True" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function IsArray1DStart1(ByRef Array1D As Variant, _" & vbLf | |
| StrCode = StrCode & " Optional ByRef ArrayName As String = ""Array1D"") _" & vbLf | |
| StrCode = StrCode & " As Boolean" & vbLf | |
| StrCode = StrCode & "'入力一次元配列の開始番号が1かどうかチェックする" & vbLf | |
| StrCode = StrCode & "'20210804" & vbLf | |
| StrCode = StrCode & "'20220309 変数名変更" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/isarray1d" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'Array1D ・・・チェックする一次元配列" & vbLf | |
| StrCode = StrCode & "'[ArrayName]・・・エラーメッセージで表示する時の名前" & vbLf | |
| StrCode = StrCode & "'20241230 Functionプロシージャにして判定結果を返す" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " If LBound(Array1D, 1) <> 1 Then" & vbLf | |
| StrCode = StrCode & " MsgBox ArrayName & ""の開始要素番号は1にしてください"", vbExclamation" & vbLf | |
| StrCode = StrCode & " Stop ''エラーを確認するために一度停止する" & vbLf | |
| StrCode = StrCode & " Exit Function ''Falseが返ってくる" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " IsArray1DStart1 = True" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function ConvArray1D_Start1(Array1D As Variant) As Variant" & vbLf | |
| StrCode = StrCode & "'開始要素番号が0の一次元配列を開始要素番号1に変換する" & vbLf | |
| StrCode = StrCode & "'20221027" & vbLf | |
| StrCode = StrCode & "'https://www.softex-celware.com/post/convarray1d_start1" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''引数チェック" & vbLf | |
| StrCode = StrCode & " If IsArray1D(Array1D) = False Then Exit Function" & vbLf | |
| StrCode = StrCode & " If LBound(Array1D, 1) = 1 Then" & vbLf | |
| StrCode = StrCode & "' MsgBox ""開始要素番号が1なので変換の必要はありません"", vbExclamation" & vbLf | |
| StrCode = StrCode & " ConvArray1D_Start1 = Array1D" & vbLf | |
| StrCode = StrCode & " Exit Function" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''処理" & vbLf | |
| StrCode = StrCode & " Dim N As Long: N = UBound(Array1D, 1)" & vbLf | |
| StrCode = StrCode & " Dim Output As Variant: ReDim Output(1 To N + 1)" & vbLf | |
| StrCode = StrCode & " Dim I As Long" & vbLf | |
| StrCode = StrCode & " For I = 1 To N + 1" & vbLf | |
| StrCode = StrCode & " If IsObject(Array1D(I - 1)) = True Then" & vbLf | |
| StrCode = StrCode & " Set Output(I) = Array1D(I - 1)" & vbLf | |
| StrCode = StrCode & " Else" & vbLf | |
| StrCode = StrCode & " Output(I) = Array1D(I - 1)" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Next" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " ''出力" & vbLf | |
| StrCode = StrCode & " ConvArray1D_Start1 = Output" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & "End Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "Private Function GetNumFromArray1D(ByRef Value As Variant, _" & vbLf | |
| StrCode = StrCode & " ByRef Array1D As Variant) _" & vbLf | |
| StrCode = StrCode & " As Long" & vbLf | |
| StrCode = StrCode & "'ValueがArray1Dの何番目の要素に当たるかを取得す" & vbLf | |
| StrCode = StrCode & "'20250106" & vbLf | |
| StrCode = StrCode & "'20250419 Array1DがEmptyの場合に0を返す" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "'引数" & vbLf | |
| StrCode = StrCode & "'Value ・・・探索する値" & vbLf | |
| StrCode = StrCode & "'Array1D・・・一次元配列" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " If IsEmpty(Array1D) = True Then Exit Function" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & " Dim I As Long" & vbLf | |
| StrCode = StrCode & " Dim N As Long: N = UBound(Array1D, 1)" & vbLf | |
| StrCode = StrCode & " Dim Output As Long" & vbLf | |
| StrCode = StrCode & " For I = 1 To N" & vbLf | |
| StrCode = StrCode & " If Value = Array1D(I) Then" & vbLf | |
| StrCode = StrCode & " Output = I" & vbLf | |
| StrCode = StrCode & " Exit For" & vbLf | |
| StrCode = StrCode & " End If" & vbLf | |
| StrCode = StrCode & " Next" & vbLf | |
| StrCode = StrCode & " " & vbLf | |
| StrCode = StrCode & " GetNumFromArray1D = Output" & vbLf | |
| StrCode = StrCode & "" & vbLf | |
| StrCode = StrCode & "End Function" | |
| Dim Book As Workbook: Set Book = ActiveWorkbook | |
| Dim ModuleName As String: ModuleName = "Mod94_SpinButtonValue" | |
| If Not AddModuleInBook(Book, ModuleName) Is Nothing Then | |
| Call AddCodeToModule(ModuleName, StrCode, Book) 'コード追加 | |
| End If | |
| 'ボタンにマクロの登録 | |
| Dim MacroName As String: MacroName = "ClickSpinButton_Value_OnAction" | |
| ButtonUp.OnAction = "'" & Book.Name & "'!" & MacroName | |
| ButtonDown.OnAction = "'" & Book.Name & "'!" & MacroName | |
| End Sub | |
| Private Function GetSelectionCell() As Range | |
| '選択中のセルを取得する | |
| 'セル以外を選択している場合はNothingを返す | |
| '20220312 | |
| 'https://www.softex-celware.com/post/getselectioncell | |
| '処理 | |
| Dim Dummy As Object: Set Dummy = Selection | |
| Dim Output As Range: Set Output = Nothing | |
| If TypeName(Dummy) = "Range" Then | |
| Set Output = Dummy | |
| End If | |
| '出力 | |
| Set GetSelectionCell = Output | |
| End Function | |
| Private Function OffsetCell(ByRef Cell As Range, _ | |
| Optional ByRef RowOffset As Long = 0, _ | |
| Optional ByRef ColOffset As Long = 0) _ | |
| As Range | |
| 'Range.Offsetプロパティの直感に反する処理を解消 | |
| 'セル結合の影響を排除する | |
| '20230127 | |
| 'https://www.softex-celware.com/post/offsetcell | |
| '引数 | |
| 'Cell ・・・基準セル | |
| '[RowOffset]・・・下方向のオフセット量 | |
| '[ColOffset]・・・右方向のオフセット量 | |
| If Cell Is Nothing Then Exit Function | |
| '処理 | |
| Dim Sheet As Worksheet: Set Sheet = Cell.Worksheet | |
| Dim Output As Range | |
| Set Output = Sheet.Cells(Cell.Row + RowOffset, _ | |
| Cell.Column + ColOffset) | |
| '出力 | |
| Set OffsetCell = Output | |
| End Function | |
| Private Function F_InputBox(ByRef Prompt As String, _ | |
| Optional ByRef Title As String, _ | |
| Optional ByRef Default As String, _ | |
| Optional ByRef Formula As Boolean = False, _ | |
| Optional ByRef Value As Boolean = False, _ | |
| Optional ByRef String_ As Boolean = False, _ | |
| Optional ByRef Boolean_ As Boolean = False, _ | |
| Optional ByRef RefCell As Boolean = False, _ | |
| Optional ByRef Error As Boolean = False, _ | |
| Optional ByRef Array_ As Boolean = False) As Variant | |
| 'Application.InputBoxのType引数の処理を個別に指定できる | |
| '20211222 | |
| '20220118修正 | |
| '20220317改良 | |
| 'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/35111320.html | |
| '引数 | |
| 'Prompt ・・・表示メッセージ | |
| '[Title] ・・・タイトル | |
| '[Default] ・・・デフォルト値 | |
| '[Formula] ・・・数式かどうか | |
| '[Value] ・・・数値かどうか | |
| '[String_] ・・・文字列かどうか | |
| '[Boolean_]・・・ブール値かどうか | |
| '[RefCell] ・・・セル参照かどうか | |
| '[Error] ・・・エラー値かどうか | |
| '[Array_] ・・・値の配列かどうか | |
| 'InputBoxのType引数を計算する | |
| Dim TypeNum As Long: TypeNum = 0 | |
| If Formula Then TypeNum = TypeNum + 0 | |
| If Value Then TypeNum = TypeNum + 1 | |
| If String_ Then TypeNum = TypeNum + 2 | |
| If Boolean_ Then TypeNum = TypeNum + 4 | |
| If RefCell Then TypeNum = TypeNum + 8 | |
| If Error Then TypeNum = TypeNum + 16 | |
| If Array_ Then TypeNum = TypeNum + 64 | |
| If TypeNum = 0 Then | |
| TypeNum = 2 'デフォルトでは文字列とする | |
| End If | |
| If RefCell = True Then | |
| Set F_InputBox = Nothing '20220317(セル選択にてキャンセルとなった場合はNothingを返す処理) | |
| On Error Resume Next | |
| If Default <> "" Then | |
| Set F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum, Default:=Default) | |
| Else | |
| Set F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum) | |
| End If | |
| On Error GoTo 0 | |
| Else | |
| If Default <> "" Then | |
| F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum, Default:=Default) | |
| Else | |
| F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum) | |
| End If | |
| End If | |
| End Function | |
| Private Function MsgYesNo(ParamArray MsgList()) As Boolean | |
| '文章だけを入力してYes,Noを訪ねてTrue/Falseを返す。 | |
| 'Yes→True | |
| 'No→False | |
| '文章は可変長引数配列で入力して自動的に改行する | |
| '20221221 | |
| 'https://www.softex-celware.com/post/msgyesno | |
| '引数 | |
| 'MsgList・・・メッセージを1行ずつ可変長引数配列で入力 | |
| 'メッセージの作成 | |
| Dim Str As Variant | |
| Dim Message As String | |
| For Each Str In MsgList | |
| If Message = "" Then '1文字目の場合 | |
| Message = Str | |
| Else '2文字目以降の場合は改行でつなげる | |
| Message = Message & vbLf & Str | |
| End If | |
| Next | |
| 'メッセージ表示とYes,Noを尋ねる | |
| Dim Output As Boolean | |
| If MsgBox(Message, vbYesNo + vbInformation) = vbYes Then | |
| Output = True | |
| Else | |
| Output = False | |
| End If | |
| '出力 | |
| MsgYesNo = Output | |
| End Function | |
| Private Function GetCellName(Cell As Range) As String | |
| 'セルに定義されている名前を取得する | |
| '20241104 | |
| '引数 | |
| 'Cell・・・対象セル | |
| Dim Output As String | |
| On Error Resume Next | |
| Output = Cell.Name | |
| On Error GoTo 0 | |
| If Output <> "" Then | |
| Output = Cell.Name.Name | |
| If InStr(Output, "!") > 0 Then | |
| Output = Split(Output, "!")(1) | |
| End If | |
| Else | |
| Output = Cell.Address(False, False) | |
| End If | |
| GetCellName = Output | |
| End Function | |
| Private Function AddModuleInBook(ByRef Book As Workbook, _ | |
| ByRef ModuleName As String) _ | |
| As VBComponent | |
| 'ブックに標準モジュールを追加する | |
| '20250711 | |
| '引数 | |
| 'Book ・・・対象ブック | |
| 'ModuleName・・・追加する標準モジュールの名前 | |
| '返り値：作成された標準モジュール すでに存在する場合はNothing | |
| Dim VBProject As VBProject: Set VBProject = Book.VBProject | |
| ' モジュールの存在確認 | |
| Dim JudgeExist As Boolean: JudgeExist = False | |
| Dim Component As VBComponent | |
| For Each Component In VBProject.VBComponents | |
| If Component.Type = 1 Then ' 標準モジュールのみ対象 | |
| If Component.Name = ModuleName Then | |
| JudgeExist = True | |
| Exit For | |
| End If | |
| End If | |
| Next Component | |
| ' なければ追加 | |
| Dim Output As VBComponent | |
| If Not JudgeExist Then | |
| Set Output = VBProject.VBComponents.Add(vbext_ct_StdModule) | |
| Output.Name = ModuleName | |
| End If | |
| '出力 | |
| Set AddModuleInBook = Output | |
| End Function | |
| Private Sub AddCodeToModule(ByRef ModuleName As String, _ | |
| ByRef CodeStr As String, _ | |
| Optional ByRef Book As Workbook) | |
| '指定のモジュールの終端にコードを追加する | |
| '20230808 | |
| '引数 | |
| 'ModuleName・・・モジュール名 | |
| 'CodeStr ・・・追加するコード | |
| '[Book] ・・・対象ブック/省略ならActiveWorkbook | |
| If Book Is Nothing Then | |
| Set Book = ActiveWorkbook | |
| End If | |
| Dim Dict_Component As Dictionary: Set Dict_Component = GetAllCodeModuleInBook(Book) | |
| Dim Component As VBComponent: Set Component = Dict_Component(ModuleName) | |
| 'コード行数取得 | |
| Dim CountOfLine As Long: CountOfLine = Component.CodeModule.CountOfLines + 1 | |
| 'コード追加 | |
| Call Component.CodeModule.InsertLines(CountOfLine, CodeStr) | |
| End Sub | |
| Private Function GetAllCodeModuleInBook(Book As Workbook) As Dictionary | |
| '指定ブックの全VBComponentを取得して連想配列に格納 | |
| '20230808 | |
| '引数 | |
| 'Book・・・対象ブック | |
| Dim Project As VBProject: Set Project = Book.VBProject 'ブックのVBProject | |
| Dim Component As VBComponent | |
| Dim Output As New Dictionary | |
| For Each Component In Project.VBComponents | |
| Output.Add Component.Name, Component | |
| Next | |
| Set GetAllCodeModuleInBook = Output | |
| End Function | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment