とりあえず
選択した範囲でB列の先頭行の項目と一致しC列にデータがないA列のセルに連番を振ります。選択した範囲のB列に複数の項目が存在した場合、先頭行の項目に一致したものだけに連番を振ります。
Sub Test()
Dim TargetRow As Long, LastRow As Long
Dim TargetColumn As Long
Dim i As Long, j As Long
Dim mRange As Range
Dim FindStr As String
If Selection(1).Column <> 1 Then
MsgBox "A列を選択してください", vbInformation
Exit Sub
End If
If Selection(1).Value <> "" Then
MsgBox "既に値が入力されています", vbInformation
Exit Sub
ElseIf Selection(1).Offset(0, 1).Value = "" Then
MsgBox "選択したセルの右隣りのセルにデータがありません", vbInformation
Exit Sub
ElseIf Selection(1).Offset(0, 2).Value <> "" Then
MsgBox "選択したセルの2個右隣りのセルにデータがあります", vbInformation
Exit Sub
End If
TargetRow = Selection(1).Row
TargetColumn = Selection(1).Column
LastRow = Cells(Rows.Count, TargetColumn + 1).End(xlUp).Row
FindStr = Cells(TargetRow, TargetColumn + 1).Value
Set mRange = Range(Cells(1, TargetColumn + 1), Cells(LastRow, TargetColumn + 1)).Find(FindStr, LookAt:=xlWhole)
If Not mRange Is Nothing Then
mRange.Offset(0, -1).Value = 1
End If
For i = TargetRow - 1 To 1 Step -1
If Cells(i, TargetColumn).Value <> "" And _
Cells(TargetRow, TargetColumn + 1).Value = Cells(i, TargetColumn + 1).Value Then
Selection(1).Value = Cells(i, TargetColumn).Value + 1
Exit For
ElseIf i = 1 Then
Selection(1).Value = 1
End If
Next
j = 1
For i = TargetRow + 1 To Cells(Rows.Count, TargetColumn).End(xlUp).Row
If (i < TargetRow + Selection.Rows.Count Or Cells(i, TargetColumn).Value <> "") And _
Cells(i, TargetColumn + 2).Value = "" And _
Cells(TargetRow, TargetColumn + 1).Value = Cells(i, TargetColumn + 1).Value Then
Cells(i, TargetColumn).Value = Selection(1).Value + j
j = j + 1
End If
Next
End Sub
お礼
何度もありがとうございました。 助かりました。