Inserting a missing row of a sequence, and accomodating a duplicate row

[CellA1234]

A member named Jim May offered some great code to add missing rows in a sequence.
However, the code gets lost if there is a duplicate row.
Would anyone know the code modification. Example:


row 1 John A
row 2 Jane b+

Jim's original code:
*******************************************
Sub Foo()
Dim FNumb As Long, TNumb As Long
Lr = Range("A" & Rows.Count).End(xlUp).Row
TNumb = Range("A" & Lr).Value
Range("A1").Select
FNumb = Selection.Value
Do Until ActiveCell.Value = TNumb
If ActiveCell.Offset(1) = (FNumb + 1) Then
Else
ActiveCell.Offset(1).EntireRow.Insert
End If
FNumb = FNumb + 1
ActiveCell.Offset(1).Select
Loop
End Sub
*******************************************

 

[CellA1234]

Place	Person	Day		Place	Person	Day
1​	Andy	Monday		1	Andy	Monday
3​	Greg	Tuesday		2
4​	Anne	Monday	Misssing rows are inserted	3	Greg	Tuesday
5​	Brad	Thursday	And duplicate rows are accepted	4	Anne	Monday
7​	Sheila	Friday	in the original sequence	5	Brad	Thursday
7​	Jane	Tuesday		6
10​	Mark	Friday		7	Sheila	Friday
				7	Jane	Tuesday
				8
				9
				10	Mark	Friday

 

[Peter_SSs]

Try this with a copy of your workbook.

Sub Insert_Rows()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, Extras As Long
  
  a = Range("A1", Range("C" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To Rows.Count, 1 To 3)
  For i = 2 To UBound(a)
    If a(i, 1) = a(i - 1, 1) Then Extras = Extras + 1
    k = a(i, 1) + Extras
    b(k, 1) = a(i, 1)
    b(k, 2) = a(i, 2)
    b(k, 3) = a(i, 3)
  Next i
  With Range("E2:G2").Resize(k)
    .Value = b
    With .Columns(1)
      On Error Resume Next
      .SpecialCells(xlBlanks).FormulaR1C1 = "=1+R[-1]C"
      On Error GoTo 0
      .Value = .Value
    End With
    .Rows(0).Value = Array("Person", "Place", "Day")
  End With
End Sub

My sample data in columns A:C and code result in E:G.

CellA1234.xlsm
	A	B	C	D	E	F	G
1	Place	Person	Day		Person	Place	Day
2	1	Andy	Monday		1	Andy	Monday
3	3	Greg	Tuesday		2
4	4	Anne	Monday		3	Greg	Tuesday
5	5	Brad	Thursday		4	Anne	Monday
6	7	Sheila	Friday		5	Brad	Thursday
7	7	Jane	Tuesday		6
8	10	Mark	Friday		7	Sheila	Friday
9					7	Jane	Tuesday
10					8
11					9
12					10	Mark	Friday
Sheet1

 

[CellA1234]

That is brilliand

Try this with a copy of your workbook.

Sub Insert_Rows()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, Extras As Long
 
  a = Range("A1", Range("C" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To Rows.Count, 1 To 3)
  For i = 2 To UBound(a)
    If a(i, 1) = a(i - 1, 1) Then Extras = Extras + 1
    k = a(i, 1) + Extras
    b(k, 1) = a(i, 1)
    b(k, 2) = a(i, 2)
    b(k, 3) = a(i, 3)
  Next i
  With Range("E2:G2").Resize(k)
    .Value = b
    With .Columns(1)
      On Error Resume Next
      .SpecialCells(xlBlanks).FormulaR1C1 = "=1+R[-1]C"
      On Error GoTo 0
      .Value = .Value
    End With
    .Rows(0).Value = Array("Person", "Place", "Day")
  End With
End Sub

My sample data in columns A:C and code result in E:G.

CellA1234.xlsm
	A	B	C	D	E	F	G
1	Place	Person	Day		Person	Place	Day
2	1	Andy	Monday		1	Andy	Monday
3	3	Greg	Tuesday		2
4	4	Anne	Monday		3	Greg	Tuesday
5	5	Brad	Thursday		4	Anne	Monday
6	7	Sheila	Friday		5	Brad	Thursday
7	7	Jane	Tuesday		6
8	10	Mark	Friday		7	Sheila	Friday
9					7	Jane	Tuesday
10					8
11					9
12					10	Mark	Friday
Sheet1

That is brilliant and genius Peter!! Thank you so much.
I managed to tweak it to four columns as well.

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.

I have removed the last line of your post. See #5 of the Forum Rules for the reason. But thanks for the thought. ?

 

[CellA1234]

?