Insert Multiple Rows Based Off Number in Cell and Copy Data From Above New Rows

[tstell1]

Hi, I would really appreciate if someone could help me with the following:

I need a macro to insert multiple rows based off a number in a cell, and then copy the information from the cell above it. For example, if cell M33 has a "3" in it, I want to add two rows below it and copy the information from the entire M33 row and paste the information into the two new rows. I want it to continue to do this for all of column M where the number "3" is found. I need to be able to adjust the macro for other numbers in column. For instance, if there is a "4" I want to insert three rows and copy the data from the row above into the three new rows. I attached a sample of the workbook that I am using.

Thanks,

tstell1
​

 

[pooja_deshpande]

try something like this

Sub k()
Dim i As Integer
i = InputBox("Insert a number")

a = Application.WorksheetFunction.CountIf(range("M:M"), i)

range("M1").Select
For j = 1 To a
range(ActiveCell, range("M" & Rows.Count)).Find(i).Offset(1, 0).Select
ActiveCell.Offset(-1, 0).EntireRow.Copy
range(ActiveCell, ActiveCell.Offset(i - 2, 0)).EntireRow.Insert
ActiveCell.Offset(i - 1, 0).Select
Next j
End Sub

 

[tstell1]

Pooja_deshpande,

Thank you for responding, I ended up finding a code yesteday. I used the following code:

Sub TryThis()
Dim i As Integer, n As Integer, m As Long, currentCell As Range
Set currentCell = ActiveCell
Do While Not IsEmpty(currentCell)
n = currentCell.Value - 1
m = currentCell.Row
If n > 0 Then
Rows(m + 1 & ":" & m + n).Insert
Set currentCell = currentCell.Offset(n + 1, 0)
Else
Set currentCell = currentCell.Offset(1, 0)
End If
Loop
End Sub

And this code to copy the contents of the cells above into the blank cells directly below:

Sub FillInBlankCellsInColumns()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim MyCounter As Long
MyCounter = 0
For Each r In Selection
On Error Resume Next
If r.Value = "" Then
r.Value = r.Offset(-1, 0).Value
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

But thank you for being willing to help and taking the time to respond.