VBA copy the last row contain certain word-CodePudding

Hellow, I want to copy the last row from every Letter (in my case Categories).

Below are my codes. It's work but I am sure there is an easy way to do that. Next question: I have about 80 entries / category, in this sample code only 6 category (F1-F6). So if I have to copy and paste the code up to F80, it's really going to be a long code, isn't it? Is there a way to simplify it?

Code:

Sub Addrows()
Dim Fnd1 As Range, Finish
Count = Application.InputBox(Prompt:="How many row?", Default:=2)

F1:
Set Fnd1 = Range("O:O").Find("A", , , xlWhole, xlByRows, xlPrevious, False, , 
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert 
Shift:=xlDown
Application.CutCopyMode = False
F2:
Set Fnd1 = Range("O:O").Find("B", , , xlWhole, xlByRows, xlPrevious, False, , 
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert 
Shift:=xlDown
Application.CutCopyMode = False
F3:
Set Fnd1 = Range("O:O").Find("C", , , xlWhole, xlByRows, xlPrevious, False, , 
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert 
Shift:=xlDown
Application.CutCopyMode = False
F4:
Set Fnd1 = Range("O:O").Find("D", , , xlWhole, xlByRows, xlPrevious, False, , 
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert 
Shift:=xlDown
Application.CutCopyMode = False
F5:
Set Fnd1 = Range("O:O").Find("E", , , xlWhole, xlByRows, xlPrevious, False, , 
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert 
Shift:=xlDown
Application.CutCopyMode = False
F6:
Set Fnd1 = Range("O:O").Find("F", , , xlWhole, xlByRows, xlPrevious, False, , 
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert 
Shift:=xlDown
Application.CutCopyMode = False
MsgBox (Count & " was added")

End Sub

CodePudding user response：

Please, try the next version. It firstly determine the unique categories (using a dictionary), then use them to insert Count rows below the last category found row, then copy the found row content in the inserted ones. It solves as many categories as they exist in "O:O" column:

   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 = 2 'it can be the result of an input in a InputBox
   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
End Sub