1 Attachment(s)
Copy the last category and insert custom text
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
Code:
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
