VBA - Read cell number value, insert new rows based on that value

Seba Robles

Board Regular
Joined
May 16, 2018
Messages
71
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
I'm trying to write a code that helps me speed up a manual process but can't seem to figure it out.

What I'm trying to achieve is for the code to go through all of the cells with data under column B until it find a cell value different from the number 1,
If a value <>1 is found, I want to insert rows below that equal to the cell value it found minus one
After the new row(s) are inserted, I want to fill down the data on columns F through Z

Look at the screenshot for a better example

7kYUzPx.jpg


On row 406, the code identified that cell B406 is 2, so it will insert 1 row below B406 and fill that newly created row (B407) with data from B406 for columns F through Z
On row 413, the code identified that cell B413 is 3, so it will insert 2 rows below B413 and it will fill the newly created rows (B414 and B415) with data from B413 for columns F though Z

And then loop from row 1 until the last row with data

Hope that is clear and will appreciate any help!
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Hi Seba Robles,

Here's one way:

VBA Code:
Option Explicit
Sub Macro1()

    Dim ws As Worksheet
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Sheets("Card Collection") 'Sheet containing the data. Change to suit if necessary.
    lngLastRow = ws.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngLastRow To 2 Step -1
        If IsNumeric(ws.Range("B" & lngMyRow)) = True And ws.Range("B" & lngMyRow) > 1 Then
            For i = 1 To ws.Range("B" & lngMyRow) - 1
                ws.Rows(lngMyRow).Insert
                ws.Rows(lngMyRow + 1).Copy Destination:=ws.Rows(lngMyRow)
            Next i
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert
 
Upvote 0
Yes! That worked perfectly!

The code took a few minutes to complete but I think that's because of all the formulas, I should've put calculations to manual beforehand.

Thank you!!
 
Upvote 0
Yes! That worked perfectly!

Thanks for letting us know and you're welcome.

The code took a few minutes to complete but I think that's because of all the formulas, I should've put calculations to manual beforehand.

Try this adaptation where the code holds the current calculation method, switches it to manual and then resets it to its original setting after the macro has run:

VBA Code:
Option Explicit
Sub Macro2()

    Dim ws As Worksheet
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim i As Long
    Dim xlnCalcMethod As XlCalculation
    
    With Application
        .ScreenUpdating = False
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    Set ws = ThisWorkbook.Sheets("Card Collection") 'Sheet containing the data. Change to suit if necessary.
    lngLastRow = ws.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngLastRow To 2 Step -1
        If IsNumeric(ws.Range("B" & lngMyRow)) = True And ws.Range("B" & lngMyRow) > 1 Then
            For i = 1 To ws.Range("B" & lngMyRow) - 1
                ws.Rows(lngMyRow).Insert
                ws.Rows(lngMyRow + 1).Copy Destination:=ws.Rows(lngMyRow)
            Next i
        End If
    Next lngMyRow
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

End Sub

Regards,

Robert
 
Upvote 0
Solution
Thanks for letting us know and you're welcome.



Try this adaptation where the code holds the current calculation method, switches it to manual and then resets it to its original setting after the macro has run:

VBA Code:
Option Explicit
Sub Macro2()

    Dim ws As Worksheet
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim i As Long
    Dim xlnCalcMethod As XlCalculation
   
    With Application
        .ScreenUpdating = False
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
    End With
   
    Set ws = ThisWorkbook.Sheets("Card Collection") 'Sheet containing the data. Change to suit if necessary.
    lngLastRow = ws.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngMyRow = lngLastRow To 2 Step -1
        If IsNumeric(ws.Range("B" & lngMyRow)) = True And ws.Range("B" & lngMyRow) > 1 Then
            For i = 1 To ws.Range("B" & lngMyRow) - 1
                ws.Rows(lngMyRow).Insert
                ws.Rows(lngMyRow + 1).Copy Destination:=ws.Rows(lngMyRow)
            Next i
        End If
    Next lngMyRow
   
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

End Sub

Regards,

Robert



Robert,

I didn't want to create a new post since my question is so similar to Seba's. I have a similar issue, and have been tweaking the code you wrote to help with that. This is the worksheet.

1617895621911.png


Column A is on the left there, and column B on the right. I want to add a new row for each value in column B (dates repeat) that is equal to 09/30/2010, and then inside the new empty cell in column B to insert a value equal to the next quarter. In this case it would be 12/31/2010.

Here's the code I have so far:

------------

Option Explicit
Sub Macro1()

Dim ws As Worksheet
Dim lngLastRow As Long
Dim lngMyRow As Long
Dim i As Long
Dim pastQuarter As Date
pastQuarter = DateValue("September 30, 2010")
Dim currentQuarter As Date
currentQuarter = DateValue("December 31, 2010")

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Sheets("DateLU") 'Sheet containing the data. Change to suit if necessary.
lngLastRow = ws.Range("B:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For lngMyRow = lngLastRow To 2 Step 1
If IsNumeric(ws.Range("B" & lngMyRow)) = True And ws.Range("B" & lngMyRow).Value = pastQuarter Then
For i = 1 To ws.Range("B" & lngMyRow) + 1
ws.Rows(lngMyRow).Insert
ws.Rows(lngMyRow + 1).Value = currentQuarter
Next i
End If
Next lngMyRow

Application.ScreenUpdating = True

End Sub

----------------------

Any suggestions on how to make this work?

Thank you so much in advance.
 
Upvote 0
Hi crezzy,

Welcome to MrExcel!!

Let me know how this goes:

VBA Code:
Option Explicit
Sub Macro2()

    Dim ws As Worksheet
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim dtePastQuarter As Date
    Dim dteCurrentQuarter As Date
    Dim xlnCalcMethod As XlCalculation
   
    With Application
        .ScreenUpdating = False
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
    End With
   
    dtePastQuarter = DateValue("September 30, 2010")
    dteCurrentQuarter = DateValue("December 31, 2010")
   
    Application.ScreenUpdating = False
   
    Set ws = ThisWorkbook.Sheets("DateLU") 'Sheet containing the data. Change to suit if necessary.
    lngLastRow = ws.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngMyRow = lngLastRow To 2 Step -1 'Work backwards (bottom up) through the rows
        If IsDate(ws.Range("B" & lngMyRow)) = True And DateValue(ws.Range("B" & lngMyRow)) = dtePastQuarter Then
            ws.Rows(lngMyRow + 1).Insert
            ws.Range("B" & lngMyRow + 1).Value = dteCurrentQuarter
        End If
    Next lngMyRow
   
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

End Sub

Regards,

Robert
 
Last edited:
Upvote 0
Hi crezzy,

Welcome to MrExcel!!

Let me know how this goes:

VBA Code:
Option Explicit
Sub Macro2()

    Dim ws As Worksheet
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim dtePastQuarter As Date
    Dim dteCurrentQuarter As Date
    Dim xlnCalcMethod As XlCalculation
  
    With Application
        .ScreenUpdating = False
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
    End With
  
    dtePastQuarter = DateValue("September 30, 2010")
    dteCurrentQuarter = DateValue("December 31, 2010")
  
    Application.ScreenUpdating = False
  
    Set ws = ThisWorkbook.Sheets("DateLU") 'Sheet containing the data. Change to suit if necessary.
    lngLastRow = ws.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    For lngMyRow = lngLastRow To 2 Step -1 'Work backwards (bottom up) through the rows
        If IsDate(ws.Range("B" & lngMyRow)) = True And DateValue(ws.Range("B" & lngMyRow)) = dtePastQuarter Then
            ws.Rows(lngMyRow + 1).Insert
            ws.Range("B" & lngMyRow + 1).Value = dteCurrentQuarter
        End If
    Next lngMyRow
  
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

End Sub

Regards,

Robert
Thanks for the warm welcome and the spruced up code. Works great :)

I took some of what your help for Seba's stuff and worked out how to copy values down from column A to the new empty cell created in each new row. It's a great code. Thank you!
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,920
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top