Insert Table Row Help! I've tried all the threads' comments I could find already...

[nhixson]

Please help; I've tried about 25 versions of different forums' code to insert a line into a table--but no luck yet. I'm just trying to have a macro that goes down a vertical list of dates in a table, starting in cell AS8, and does the following:

First checks to see if the cell to the left (AR8 in this first case) is zero. If so, it goes to the next cell down. If not, it adds blank table rows below the current row (number of rows to add being in AR8). It then moves down to the next row. This loop continues until it hits an empty cell. Here's an example of the what the data in the worksheet looks like:

AR AS
[TABLE="class: cms_table, width: 177"]
<tbody>[TR]
[TD]0[/TD]
[TD]7/5/2013[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]8/4/2013[/TD]
[/TR]
[TR]
[TD]0[/TD]
[TD]11/30/2013[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]12/1/2013[/TD]
[/TR]
[TR]
[TD]0[/TD]
[TD]2/28/2014[/TD]
[/TR]
[TR]
[TD]0[/TD]
[TD]4/1/2013[/TD]
[/TR]
[TR]
[TD]0[/TD]
[TD]4/1/2013[/TD]
[/TR]
</tbody>[/TABLE]

And here's my best attempt so far at the code:
Sub FillinLines()
Do
If ActiveCell.Offset(0, -1) = 0 Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Select
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell.Offset(0, 0))
End Sub

Any help would be very appreciated!
-Nate

 

[mumps]

Hi Nate. Does this work for you?

Sub AddRows()
    Application.ScreenUpdating = False
    Dim bottomAS As Integer
    bottomAS = Range("AS" & Rows.Count).End(xlUp).Row
    Dim x As Long
    Dim y As Long
    For x = 2 To bottomAS
        If Cells(x, "AS") <> 0 Then
            For y = 1 To Cells(x, "AS").Value
                Cells(x + 1, "AS").EntireRow.Insert
            Next y
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[nhixson]

Hi mumps,

Thanks for your help. I selected the first date in column AS in the table and then ran your macro. It popped up with a box that said
Run-time error '13'
Type mismatch

And when I click debug, it highlights this line in yellow:
For y=1 To Cells (x, "AS").Value

Any ideas for how to fix it?

 

[mumps]

My apologies. Try:

Sub AddRows()
    Application.ScreenUpdating = False
    Dim bottomAR As Long
    bottomAR = Range("AR" & Rows.Count).End(xlUp).Row
    Dim x As Long
    Dim y As Long
    For x = 2 To bottomAR
        If Cells(x, "AR") <> 0 Then
            For y = 1 To Cells(x, "Ar").Value
                Cells(x + 1, "AR").EntireRow.Insert
            Next y
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[nhixson]

Exact same thing happens.

The code I originally posted stops at the correct cell, it just won't insert a table row beneath like I want. Is that even possible? Just the line or two of code that inserts a table row would be great.

 

[mumps]

When I tried it on a dummy sheet, it worked for me. I'm not sure what is happening in your case. If you could upload your file to a free site such as www.box.com where you can get a link to your file, you could post the link here. It is always easier to find the problem if I can work with the original file.

 

[nhixson]

Thanks for taking a look. I uploaded it to Box as you suggested.

https://app.box.com/s/nkiik4s9f9dfhxko9dca

 

[mumps]

Try this macro:

Sub AddRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long
    Dim y As Long
    For x = 11 To LastRow
        If Cells(x, "AR") <> 0 Then
            For y = 1 To Cells(x, "AR").Value
                Cells(x + 1, "AR").EntireRow.Insert
            Next y
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[nhixson]

Hi mumps

Thank you so much! It works great! You're a rockstar.

 

[mumps]

My pleasure!