MyRibbonTools D02_Cvt

Option Explicit

'+++*********************************************************+++
'    指定シート・列・形式でデータを変換し、カンマ等で整形表示
'    formatType: "number", "comma", "text", "date"
'    colList: "2,5,7" のようにカンマ区切りで列番号指定
'    IsCall: Trueなら画面更新制御なし、Falseなら制御あり
'    使用例：
'        Call FormatColumns(wsData, "2,5,7", "comma", False)
'        Call FormatColumns(Sheets("DataSheet"), "2,5,7", "comma", False)
'+++*********************************************************+++
Sub FormatColumns(ByVal targetSheet As Worksheet, ByVal colList As String, _
        ByVal formatType As String, Optional ByVal IsCall As Boolean = False)

    '=== 変数宣言 ===
    Dim colArr() As String
    Dim colNO As Long
    Dim MaxRow As Long
    Dim sttRow As Long, endRow As Long
    Dim maxNo As Long: maxNo = 25000
    Dim i As Long, j As Long, x As Long
    Dim loopMax As Long
    Dim myArray1 As Variant, myArray2 As Variant
    Dim tmpArr As Variant

    '=== 前処理 ===
    If IsCall = False Then Call StopUpdating
    Call ClearAllFilters

    colArr = Split(colList, ",")

    With targetSheet
        For j = LBound(colArr) To UBound(colArr)
            colNO = CLng(Trim(colArr(j)))
            sttRow = .Cells(2, colNO).Row
            MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row

            '=== 分割処理の回数を決定 ===
            If (MaxRow - sttRow) < maxNo Then
                loopMax = 1
            Else
                loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0)
            End If

            '=== 分割ループ処理 ===
            For x = 1 To loopMax
                If sttRow + maxNo > MaxRow Then
                    endRow = MaxRow
                Else
                    endRow = sttRow + maxNo
                End If

                myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
                ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))

                '=== 表示形式の設定 ===
                Select Case LCase(formatType)
                    Case "comma": .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "#,##0"
                    Case "number": .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "0"
                    Case "text": .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "@"
                    Case "date": .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "yyyy/mm/dd"
                End Select

                '=== データ変換処理 ===
                For i = LBound(myArray1, 1) To UBound(myArray1, 1)
                    If IsError(myArray1(i, 1)) Then
                        myArray2(i) = myArray1(i, 1)
                    ElseIf myArray1(i, 1) <> "" Then
                        Select Case LCase(formatType)
                            Case "comma", "number"
                                If IsNumeric(myArray1(i, 1)) Then
                                    myArray2(i) = val(myArray1(i, 1))
                                Else
                                    myArray2(i) = myArray1(i, 1)
                                End If
                            Case Else
                                myArray2(i) = myArray1(i, 1)
                        End Select
                    Else
                        myArray2(i) = ""
                    End If
                Next i

                '=== 安全な縦方向配列に変換して貼り付け ===
                ReDim tmpArr(1 To UBound(myArray2), 1 To 1)
                For i = 1 To UBound(myArray2)
                    tmpArr(i, 1) = myArray2(i)
                Next i
                .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr

                Erase myArray1: Erase myArray2: Erase tmpArr
                sttRow = endRow + 1
            Next x
        Next j
    End With
    
    '=== 後処理 ===
    '=== 他ブックから呼び出された場合は最小化 ===
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then
        Windows(ThisWorkbook.Name).WindowState = xlMinimized
    End If
    
    '=== 画面更新再開 ===
    If IsCall = False Then Call Updating
    
End Sub
'+++*********************************************************+++
'    指定シート・列で7桁ゼロ埋め整形（数値かつ7桁以下のみ対象）
'    colList: "2,5,7" のようにカンマ区切りで列番号指定
'    IsCall: Trueなら画面更新制御なし、Falseなら制御あり
'    使用例：
'        Call FormatTo7DigitZero(Sheets("Data"), "3,6,9", False)
'+++*********************************************************+++
Sub FormatTo7DigitZero(ByVal targetSheet As Worksheet, ByVal colList As String, _
        Optional ByVal IsCall As Boolean = False)

    '=== 変数宣言 ===
    Dim colArr() As String
    Dim colNO As Long
    Dim MaxRow As Long, sttRow As Long, endRow As Long
    Dim maxNo As Long: maxNo = 25000
    Dim i As Long, j As Long, x As Long, loopMax As Long
    Dim myArray1 As Variant, myArray2 As Variant
    Dim tmpArr As Variant

    '=== 前処理 ===
    If IsCall = False Then Call StopUpdating
    Call ClearAllFilters

    colArr = Split(colList, ",")

    With targetSheet
        For j = LBound(colArr) To UBound(colArr)
            colNO = CLng(Trim(colArr(j)))
            sttRow = .Cells(2, colNO).Row
            MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row

            '=== 分割処理の回数を決定 ===
            If (MaxRow - sttRow) < maxNo Then
                loopMax = 1
            Else
                loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0)
            End If

            '=== 分割ループ処理 ===
            For x = 1 To loopMax
                If sttRow + maxNo > MaxRow Then
                    endRow = MaxRow
                Else
                    endRow = sttRow + maxNo
                End If

                myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
                ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))

                '=== ゼロ埋め変換処理（数値かつ7桁以下） ===
                For i = LBound(myArray1, 1) To UBound(myArray1, 1)
                    If IsError(myArray1(i, 1)) Then
                        myArray2(i) = myArray1(i, 1)
                    ElseIf IsNumeric(myArray1(i, 1)) Then
                        If Len(CStr(myArray1(i, 1))) <= 7 Then
                            myArray2(i) = Format(myArray1(i, 1), "0000000")
                        Else
                            myArray2(i) = myArray1(i, 1)
                        End If
                    Else
                        myArray2(i) = myArray1(i, 1)
                    End If
                Next i

                '=== 安全な縦方向配列に変換して貼り付け ===
                ReDim tmpArr(1 To UBound(myArray2), 1 To 1)
                For i = 1 To UBound(myArray2)
                    tmpArr(i, 1) = myArray2(i)
                Next i
                .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr

                Erase myArray1: Erase myArray2: Erase tmpArr
                sttRow = endRow + 1
            Next x
        Next j
    End With

    '=== 後処理 ===
    '=== 他ブックから呼び出された場合は最小化 ===
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then
        Windows(ThisWorkbook.Name).WindowState = xlMinimized
    End If
    
    '=== 画面更新再開 ===
    If IsCall = False Then Call Updating
    
End Sub
'+++*********************************************************+++
'    指定シート・列を全角数字・全角ハイフン・全角アルファベット・カタカナに変換（文字列として保持）
'    テーブル・通常フィルターを解除してから処理
'    ※ Microsoft Scripting Runtime の参照設定が必要
'    使用例：
'        Call FormatToZenkaku(Sheets("Data"), "2,5,7")
'+++*********************************************************+++
Sub FormatToZenkaku(ByVal targetSheet As Worksheet, ByVal colList As String, _
                    Optional ByVal startRow As Long = 2, Optional ByVal maxNo As Long = 25000)

    '=== 変数宣言 ===
    Dim colArr() As String
    Dim colNO As Long, sttRow As Long, endRow As Long, MaxRow As Long
    Dim i As Long, x As Long, loopMax As Long
    Dim myArray1 As Variant, myArray2 As Variant
    Dim tmpArr As Variant
    Dim colStr As Variant

    '=== 前処理 ===
    If IsCall = False Then Call StopUpdating
    Call ClearAllFilters

    colArr = Split(colList, ",")

    For Each colStr In colArr
        colNO = CLng(Trim(colStr))
        sttRow = startRow

        With targetSheet
            MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row

            '=== 分割処理の回数を決定 ===
            If (MaxRow - sttRow) < maxNo Then
                loopMax = 1
            Else
                loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0)
            End If

            '=== 分割ループ処理 ===
            For x = 1 To loopMax
                If sttRow + maxNo > MaxRow Then
                    endRow = MaxRow
                Else
                    endRow = sttRow + maxNo
                End If

                '=== 対象範囲の取得と書式設定 ===
                myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
                ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
                .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "@"

                '=== 変換処理（全角化） ===
                For i = LBound(myArray1, 1) To UBound(myArray1, 1)
                    If IsError(myArray1(i, 1)) Then
                        myArray2(i) = myArray1(i, 1)
                    ElseIf myArray1(i, 1) <> "" Then
                        myArray2(i) = ToZenkakuNumHyphenAlphaKana(CStr(myArray1(i, 1)))
                    Else
                        myArray2(i) = ""
                    End If
                Next i

                '=== 安全な縦方向配列に変換して貼り付け ===
                ReDim tmpArr(1 To UBound(myArray2), 1 To 1)
                For i = 1 To UBound(myArray2)
                    tmpArr(i, 1) = myArray2(i)
                Next i
                .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr

                Erase myArray1: Erase myArray2: Erase tmpArr
                sttRow = endRow + 1
            Next x
        End With
    Next colStr

    '=== 後処理 ===
    '=== 他ブックから呼び出された場合は最小化 ===
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then
        Windows(ThisWorkbook.Name).WindowState = xlMinimized
    End If
    
    '=== 画面更新再開 ===
    If IsCall = False Then Call Updating
    
End Sub
'+++*********************************************************+++
'    半角の数字・英字・ハイフン・カタカナを全角に変換（濁点・半濁点対応）
'    ※ Microsoft Scripting Runtime の参照設定が必要
'    使用例：
'        result = ToZenkakuNumHyphenAlphaKana("ｶﾞｯﾂﾎﾟｰｽﾞ 123-abc")
'        → "ガッツポーズ　１２３－ａｂｃ"
'+++*********************************************************+++
Function ToZenkakuNumHyphenAlphaKana(str As String) As String
    Dim i As Long
    Dim result As String
    Dim c As String, NextChar As String
    Dim code As Long
    Dim KanaMap As Dictionary, DakutenMap As Dictionary, HandakutenMap As Dictionary

    '=== 辞書の初期化 ===
    Set KanaMap = New Dictionary
    Set DakutenMap = New Dictionary
    Set HandakutenMap = New Dictionary

    '=== 半角 → 全角カタカナ基本変換 ===
    With KanaMap
        .Add "ｱ", "ア": .Add "ｲ", "イ": .Add "ｳ", "ウ": .Add "ｴ", "エ": .Add "ｵ", "オ"
        .Add "ｶ", "カ": .Add "ｷ", "キ": .Add "ｸ", "ク": .Add "ｹ", "ケ": .Add "ｺ", "コ"
        .Add "ｻ", "サ": .Add "ｼ", "シ": .Add "ｽ", "ス": .Add "ｾ", "セ": .Add "ｿ", "ソ"
        .Add "ﾀ", "タ": .Add "ﾁ", "チ": .Add "ﾂ", "ツ": .Add "ﾃ", "テ": .Add "ﾄ", "ト"
        .Add "ﾅ", "ナ": .Add "ﾆ", "ニ": .Add "ﾇ", "ヌ": .Add "ﾈ", "ネ": .Add "ﾉ", "ノ"
        .Add "ﾊ", "ハ": .Add "ﾋ", "ヒ": .Add "ﾌ", "フ": .Add "ﾍ", "ヘ": .Add "ﾎ", "ホ"
        .Add "ﾏ", "マ": .Add "ﾐ", "ミ": .Add "ﾑ", "ム": .Add "ﾒ", "メ": .Add "ﾓ", "モ"
        .Add "ﾔ", "ヤ": .Add "ﾕ", "ユ": .Add "ﾖ", "ヨ"
        .Add "ﾗ", "ラ": .Add "ﾘ", "リ": .Add "ﾙ", "ル": .Add "ﾚ", "レ": .Add "ﾛ", "ロ"
        .Add "ﾜ", "ワ": .Add "ｦ", "ヲ": .Add "ﾝ", "ン"
        .Add "ｧ", "ァ": .Add "ｨ", "ィ": .Add "ｩ", "ゥ": .Add "ｪ", "ェ": .Add "ｫ", "ォ"
        .Add "ｯ", "ッ": .Add "ｬ", "ャ": .Add "ｭ", "ュ": .Add "ｮ", "ョ"
        .Add "｡", "。": .Add "｢", "「": .Add "｣", "」": .Add "､", "、": .Add "･", "・"
    End With

    '=== 濁点合成マップ（例: ｶﾞ → ガ）===
    With DakutenMap
        .Add "カ", "ガ": .Add "キ", "ギ": .Add "ク", "グ": .Add "ケ", "ゲ": .Add "コ", "ゴ"
        .Add "サ", "ザ": .Add "シ", "ジ": .Add "ス", "ズ": .Add "セ", "ゼ": .Add "ソ", "ゾ"
        .Add "タ", "ダ": .Add "チ", "ヂ": .Add "ツ", "ヅ": .Add "テ", "デ": .Add "ト", "ド"
        .Add "ハ", "バ": .Add "ヒ", "ビ": .Add "フ", "ブ": .Add "ヘ", "ベ": .Add "ホ", "ボ"
        .Add "ウ", "ヴ"
    End With

    '=== 半濁点合成マップ（例: ﾊﾟ → パ）===
    With HandakutenMap
        .Add "ハ", "パ": .Add "ヒ", "ピ": .Add "フ", "プ": .Add "ヘ", "ペ": .Add "ホ", "ポ"
    End With

    '=== 変換処理本体 ===
    result = ""
    i = 1
    Do While i <= Len(str)
        c = Mid(str, i, 1)
        code = AscW(c)

        Select Case code
            Case 48 To 57, 65 To 90, 97 To 122
                result = result & ChrW(code + 65248) ' 半角英数字 → 全角
            Case 45
                result = result & ChrW(65293)        ' 半角ハイフン → 全角
            Case Else
                If KanaMap.Exists(c) Then
                    If i < Len(str) Then
                        NextChar = Mid(str, i + 1, 1)
                        If NextChar = "ﾞ" And DakutenMap.Exists(KanaMap(c)) Then
                            result = result & DakutenMap(KanaMap(c))
                            i = i + 1
                        ElseIf NextChar = "ﾟ" And HandakutenMap.Exists(KanaMap(c)) Then
                            result = result & HandakutenMap(KanaMap(c))
                            i = i + 1
                        Else
                            result = result & KanaMap(c)
                        End If
                    Else
                        result = result & KanaMap(c)
                    End If
                Else
                    result = result & c
                End If
        End Select
        i = i + 1
    Loop

    ToZenkakuNumHyphenAlphaKana = result
End Function
'+++*********************************************************+++
'    指定シート・列を「カタカナのみ全角、他は半角」に変換（文字列として保持）
'    テーブル・通常フィルターを解除してから処理
'    ※ Microsoft Scripting Runtime の参照設定が必要
'    使用例：
'        Call FormatToKatakanaZenkakuOnly(Sheets("Data"), "2,5,7")
'+++*********************************************************+++
Sub FormatToKatakanaZenkakuOnly(ByVal targetSheet As Worksheet, ByVal colList As String, _
                                 Optional ByVal startRow As Long = 2, Optional ByVal maxNo As Long = 25000)

    '=== 変数宣言 ===
    Dim colArr() As String
    Dim colNO As Long, sttRow As Long, endRow As Long, MaxRow As Long
    Dim i As Long, x As Long, loopMax As Long
    Dim myArray1 As Variant, myArray2 As Variant
    Dim tmpArr As Variant
    Dim colStr As Variant

    '=== 前処理 ===
    If IsCall = False Then Call StopUpdating
    Call ClearAllFilters

    colArr = Split(colList, ",")

    For Each colStr In colArr
        colNO = CLng(Trim(colStr))
        sttRow = startRow

        With targetSheet
            MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row

            '=== 分割処理の回数を決定 ===
            If (MaxRow - sttRow) < maxNo Then
                loopMax = 1
            Else
                loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0)
            End If

            '=== 分割ループ処理 ===
            For x = 1 To loopMax
                If sttRow + maxNo > MaxRow Then
                    endRow = MaxRow
                Else
                    endRow = sttRow + maxNo
                End If

                '=== 対象範囲の取得と書式設定 ===
                myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
                ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
                .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "@"

                '=== 変換処理（カタカナのみ全角） ===
                For i = LBound(myArray1, 1) To UBound(myArray1, 1)
                    If IsError(myArray1(i, 1)) Then
                        myArray2(i) = myArray1(i, 1)
                    ElseIf myArray1(i, 1) <> "" Then
                        myArray2(i) = ToKatakanaZenkakuOnly(CStr(myArray1(i, 1)))
                    Else
                        myArray2(i) = ""
                    End If
                Next i

                '=== 安全な縦方向配列に変換して貼り付け ===
                ReDim tmpArr(1 To UBound(myArray2), 1 To 1)
                For i = 1 To UBound(myArray2)
                    tmpArr(i, 1) = myArray2(i)
                Next i
                .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr

                Erase myArray1: Erase myArray2: Erase tmpArr
                sttRow = endRow + 1
            Next x
        End With
    Next colStr

    '=== 後処理 ===
    '=== 他ブックから呼び出された場合は最小化 ===
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then
        Windows(ThisWorkbook.Name).WindowState = xlMinimized
    End If
    
    '=== 画面更新再開 ===
    If IsCall = False Then Call Updating
    
End Sub
'+++*********************************************************+++
'    カタカナのみ全角に変換、他は半角のまま保持
'    濁点・半濁点にも対応（例: ｶﾞ → ガ、ﾊﾟ → パ）
'    ※ Microsoft Scripting Runtime の参照設定が必要
'    使用例：
'        result = ToKatakanaZenkakuOnly("ｶﾞｯﾂﾎﾟｰｽﾞ 123-abc")
'        → "ガッツポーズ 123-abc"
'+++*********************************************************+++
Function ToKatakanaZenkakuOnly(str As String) As String

    Dim i As Long
    Dim result As String
    Dim c As String, NextChar As String
    Dim KanaMap As Dictionary, DakutenMap As Dictionary, HandakutenMap As Dictionary

    '=== 辞書の初期化 ===
    Set KanaMap = New Dictionary
    Set DakutenMap = New Dictionary
    Set HandakutenMap = New Dictionary

    '=== 半角 → 全角カタカナ基本変換 ===
    With KanaMap
        .Add "ｱ", "ア": .Add "ｲ", "イ": .Add "ｳ", "ウ": .Add "ｴ", "エ": .Add "ｵ", "オ"
        .Add "ｶ", "カ": .Add "ｷ", "キ": .Add "ｸ", "ク": .Add "ｹ", "ケ": .Add "ｺ", "コ"
        .Add "ｻ", "サ": .Add "ｼ", "シ": .Add "ｽ", "ス": .Add "ｾ", "セ": .Add "ｿ", "ソ"
        .Add "ﾀ", "タ": .Add "ﾁ", "チ": .Add "ﾂ", "ツ": .Add "ﾃ", "テ": .Add "ﾄ", "ト"
        .Add "ﾅ", "ナ": .Add "ﾆ", "ニ": .Add "ﾇ", "ヌ": .Add "ﾈ", "ネ": .Add "ﾉ", "ノ"
        .Add "ﾊ", "ハ": .Add "ﾋ", "ヒ": .Add "ﾌ", "フ": .Add "ﾍ", "ヘ": .Add "ﾎ", "ホ"
        .Add "ﾏ", "マ": .Add "ﾐ", "ミ": .Add "ﾑ", "ム": .Add "ﾒ", "メ": .Add "ﾓ", "モ"
        .Add "ﾔ", "ヤ": .Add "ﾕ", "ユ": .Add "ﾖ", "ヨ"
        .Add "ﾗ", "ラ": .Add "ﾘ", "リ": .Add "ﾙ", "ル": .Add "ﾚ", "レ": .Add "ﾛ", "ロ"
        .Add "ﾜ", "ワ": .Add "ｦ", "ヲ": .Add "ﾝ", "ン"
        .Add "ｧ", "ァ": .Add "ｨ", "ィ": .Add "ｩ", "ゥ": .Add "ｪ", "ェ": .Add "ｫ", "ォ"
        .Add "ｯ", "ッ": .Add "ｬ", "ャ": .Add "ｭ", "ュ": .Add "ｮ", "ョ"
        .Add "｡", "。": .Add "｢", "「": .Add "｣", "」": .Add "､", "、": .Add "･", "・"
    End With

    '=== 濁点・半濁点合成マップ ===
    With DakutenMap
        .Add "カ", "ガ": .Add "キ", "ギ": .Add "ク", "グ": .Add "ケ", "ゲ": .Add "コ", "ゴ"
        .Add "サ", "ザ": .Add "シ", "ジ": .Add "ス", "ズ": .Add "セ", "ゼ": .Add "ソ", "ゾ"
        .Add "タ", "ダ": .Add "チ", "ヂ": .Add "ツ", "ヅ": .Add "テ", "デ": .Add "ト", "ド"
        .Add "ハ", "バ": .Add "ヒ", "ビ": .Add "ﾌ", "ブ": .Add "ﾍ", "ベ": .Add "ﾎ", "ボ"
        .Add "ウ", "ヴ"
    End With

    With HandakutenMap
        .Add "ハ", "パ": .Add "ヒ", "ピ": .Add "フ", "プ": .Add "ヘ", "ペ": .Add "ホ", "ポ"
    End With

    '=== 変換処理本体 ===
    result = ""
    i = 1
    Do While i <= Len(str)
        c = Mid(str, i, 1)

        If KanaMap.Exists(c) Then
            If i < Len(str) Then
                NextChar = Mid(str, i + 1, 1)
                If NextChar = "ﾞ" And DakutenMap.Exists(KanaMap(c)) Then
                    result = result & DakutenMap(KanaMap(c))
                    i = i + 1
                ElseIf NextChar = "ﾟ" And HandakutenMap.Exists(KanaMap(c)) Then
                    result = result & HandakutenMap(KanaMap(c))
                    i = i + 1
                Else
                    result = result & KanaMap(c)
                End If
            Else
                result = result & KanaMap(c)
            End If
        Else
            result = result & ToHankaku(c) ' カタカナ以外は半角に変換
        End If
        i = i + 1
    Loop

    ToKatakanaZenkakuOnly = result
End Function
'+++*********************************************************+++
'    アクティブセルの列をゼロ埋めして文字列化（指定桁数）
'    数値以外はそのまま保持（空白・エラーも含む）
'    テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub CvtToStr_LeadingZeros()

    '=== 変数宣言 ===
    Dim MaxRow As Long
    Dim R As Range
    Dim i As Long, x As Long
    Dim loopMax As Long         'ループ最大回数
    Dim colNO As Long
    Dim cellval As Variant
    Dim myArray1 As Variant, myArray2 As Variant
    Dim tmpArr As Variant       '貼り付け用2次元配列
    Dim sttRow As Long, endRow As Long
    Dim maxNo As Long: maxNo = 25000
    Dim padLength As Long: padLength = 7 ' ← 必要に応じて桁数変更可

    '=== 画面更新停止・フィルター解除 ===
    If IsCall = False Then Call StopUpdating
    Call ClearAllFilters

    '=== アクティブセル情報取得 ===
    Set R = ActiveCell
    sttRow = R.Row
    colNO = R.Column

    With ActiveSheet
        MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row

        '=== 書式を文字列に変更 ===
        .Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "@"

        If MaxRow = sttRow Then
            '=== 1セルだけの時は個別処理 ===
            cellval = R.Value
            If Not IsError(cellval) And CStr(cellval) <> "" Then
                If IsNumeric(cellval) Then
                    R.Value = Format(CDbl(CStr(cellval)), String(padLength, "0"))
                Else
                    R.Value = cellval
                End If
            End If
        Else
            '=== 通常の複数セル処理 ===
            If (MaxRow - sttRow) < maxNo Then
                loopMax = 1
            Else
                loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
            End If

            '=== 分割処理ループ ===
            For x = 1 To loopMax
                If sttRow + maxNo - 1 > MaxRow Then
                    endRow = MaxRow
                Else
                    endRow = sttRow + maxNo - 1
                End If

                myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
                ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))

                '=== 型変換処理（ゼロ埋め） ===
                For i = LBound(myArray1, 1) To UBound(myArray1, 1)
                    cellval = myArray1(i, 1)
                    If IsError(cellval) Then
                        myArray2(i) = cellval
                    ElseIf cellval <> "" Then
                        If IsNumeric(cellval) Then
                            myArray2(i) = Format(CDbl(CStr(cellval)), String(padLength, "0"))
                        Else
                            myArray2(i) = cellval
                        End If
                    Else
                        myArray2(i) = ""
                    End If
                Next i

                '=== 安全な縦方向配列に変換して貼り付け ===
                ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
                For i = LBound(myArray2) To UBound(myArray2)
                    tmpArr(i, 1) = myArray2(i)
                Next i

                .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr

                Erase myArray1: Erase myArray2: Erase tmpArr
                sttRow = endRow + 1
            Next x
        End If
    End With

    '=== 後処理 ===
    '=== 他ブックから呼び出された場合は最小化 ===
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then
        Windows(ThisWorkbook.Name).WindowState = xlMinimized
    End If
    
    '=== 画面更新再開 ===
    If IsCall = False Then Call Updating
    
End Sub