【マクロ・VBA】縦（行）ループして連番を振る　

Sub 最終列に連番を振る()

Dim wb1 As Workbook
Set wb1 = ThisWorkbook
Dim ws1 As Worksheet
Set ws1 = ActiveSheet

Dim LastRow1 As Long
LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row

Dim LastCol1 As Long
LastCol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

Dim i, 連番
 
 連番 = 1
 For i = 2 To LastRow1
   Cells(i, LastCol1 + 1).Value = 連番
   連番 = 連番 + 1
 Next

Cells(1, LastCol1 + 1) = "もとの順番"

 MsgBox "完了"
End Sub

Sub 連番()

    Dim i As Long, 指定行 As Long, 連番 As Long, LastCol1 As Long

    指定行 = 2
    連番 = 1

    Columns("A").Insert

    LastCol1 = ThisWorkbook.ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

    For i = 指定行 To ThisWorkbook.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
        ThisWorkbook.ActiveSheet.Cells(i, LastCol1 + 1).Value = 連番
        連番 = 連番 + 1

        If i = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row Then
            MsgBox "完了"
            Exit Sub
        End If
    Next

    Range("A1") = "No"

    MsgBox "完了"
End Sub

Sub 列挿入_カウント用の１をたてる()

Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A2").Select

Dim i
For i = 2 To ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
       Cells(i, 1) = 1
Next

Range("A1") = "カウント"

MsgBox "完了"
End Sub

Sub 同じデータに同じ連番をふる()

Dim DicName As Variant
Dim i As Long
Dim j As Long
Dim Cnt As Long
Dim LastRow As Long
Dim GetName As String
Dim myKey As Variant
    
    '連想配列にいれる
    Set DicName = CreateObject("Scripting.Dictionary")

    '最終行を取得
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row

    '行をループ
    For i = 2 To LastRow

        '1列目の値を変数へ
        GetName = Cells(i, 1)

        '重複しないリストを連想配列へ
        If Not DicName.Exists(GetName) Then
            DicName.Add GetName, GetName
        End If
    Next i

    Dim LastCol1 As Long
    LastCol1 = Cells(1, Columns.Count).End(xlToLeft).Column

    myKey = DicName.keys
    Cnt = 1

    'リスト分ループ
    For i = 0 To UBound(DicName.items)

        For j = 1 To LastRow
            If Cells(j, 1) = myKey(i) Then

                '最終列に通し番号を振る
                 Cells(j, LastCol1 + 1) = Cnt

            End If
        Next j

        Cnt = Cnt + 1

    Next i

    Set DicName = Nothing

MsgBox "完了 "
End Sub