Copy the last category and insert custom text

[chrisade]

Hello guys, this code will copy twice the entire cell from last row for each category(A,B,C,D...). Now how to insert custom text for column E and P (Green column)? So the 1st copy and the 2nd copy will have different value and it will be nice if I can use inputbox to determine those values. So it will ask:

• How many row
• Text 1 for E
• Text 2 for E
• Text 1 for P
• Text 2 for P

any help would be greatly appreciated

excelvba2.jpg

Sub Zeile_einfügen()
      Dim sh As Worksheet, lastRow As Long, rngOO As Range, Fnd1 As Range
   Dim i As Long, Count As Long, arr, dict As Object
   
   Count = Application.InputBox(Prompt:="How many row?", Default:=2)
   Txt1E= Application.InputBox(Prompt:="1st Item Number?")
   Txt2E= Application.InputBox(Prompt:="2nd Item Number?")
   Txt1P= Application.InputBox(Prompt:="1st Kommentar_2?")
   Txt2P= Application.InputBox(Prompt:="2nd Kommentar_2?")
   
   Set sh = ActiveSheet
   lastRow = sh.Range("O" & sh.Rows.Count).End(xlUp).Row
   Set rngOO = sh.Range("O3:O" & lastRow)
   arr = rngOO.Value 'place the row in an array for faster iteration
   
   Set dict = CreateObject("Scripting.Dictionary")
   'Extract the unique categories:
   For i = 1 To UBound(arr)
        If arr(i, 1) <> "" Then dict(arr(i, 1)) = Empty
   Next i
   
   'finding the last unique categories and do copy its row of Count times:
   For i = 0 To dict.Count - 1
        Set Fnd1 = rngOO.Find(dict.Keys()(i), , , xlWhole, xlByRows, xlPrevious, False, , False)
        Fnd1.EntireRow.Copy
        sh.Range(Fnd1.Offset(1, 0), Fnd1.Offset(Count, 0)).EntireRow.Insert Shift:=xlDown
        Next i
   MsgBox (Count & " Row/s are added")
End Sub

Link to the other post:
https://www.excelforum.com/excel-pro...ml#post5623069