一番上の入り口へ > excel > VBA コーディングライブラリ集 > 番号を順番に挿入するマクロ

番号を順番に挿入するマクロ

縦方向に1(または開始セルの値)から順番(index)を順次挿入します。

空白か数字であれば 番号を挿入
文字列やハイフン等であれば skip(何もしない)
(1-1)などは未対応


Sub 連番挿入()

    '概要
    '縦方向に1(または開始セルの値)から順番(index)を順次挿入
    ' 空白か数字であれば 番号を挿入
    ' 文字列やハイフン等であれば skip(何もしない)
    '   (1-1)などは未対応
    
    '  開始セルはセレクションの左上
    '  その列と ターゲット列(tc = c + 1)両方で空白が voidmaxnum 続いていたら終了(最大 maxRow)
    
    '準備-------------------------------------------------

    Dim r As Integer, c As Integer
    Dim tc As Integer, index As Integer
    
    Dim voidnum As Integer, voidmaxnum As Integer, maxRow As Integer
    
    
    '各種メイン設定値
    r = Selection.row
    c = Selection.column
    tc = c + 1
    
    voidmaxnum = 5
    maxRow = 3000
    index = 1
    
    'program用設定
    voidnum = 0
    

    '範囲チェック------------------------------------------
    For i = r To maxRow
        If (Cells(i, tc).Value = Empty And (Cells(i, c).Value = Empty Or Cells(i, c).Value = "")) Then
            voidnum = voidnum + 1
            If (voidmaxnum < voidnum) Then
                maxRow = i - voidmaxnum - 1
                Exit For
            End If
        Else
            voidnum = 0
        End If
    Next
    
    '挿入---------------------------------------------------
    
        'リフレッシュチェック
    If maxRow - r > 50 Then
        Application.ScreenUpdating = False
    End If
    
    index = 0
    For i = r To maxRow
        If (IsNumeric(Cells(i, c).Value) Or Cells(i, c).Value = Empty Or Cells(i, c).Value = "") Then
            Rows(i).Select
            
            Cells(i, c).Value = index
            index = index + 1
        End If
        
        If (i Mod 500 = 0) Then
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False
        End If
    
    Next
    
    Application.ScreenUpdating = True
    MsgBox (r & "行, " & c & "列  から" & maxRow & "行まで挿入しました。" & vbCrLf & "maxIndex:" & (index - 1))
    
End Sub

類似リンク

複数のページにわたる連番を簡単に入れるちょいわざ

VBA マクロライブラリ集