Add rows to a table when you fill the last row?

[madvogue29]

Hi all I am looking for a dynamic solution that adds rows to my tables on a sheet when it is almost full.

I am using this (Code below) where range B2 and E2 keep track of the last cell in each table.
I am going to work with script that generates new tables dynamically and this solution wont work. Can someone please help.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells, KeyCells2, KeyCells3 As Range
   
    Dim x, i, a, b As Integer
   
    i = Sheets("Sheet2").Range("B2").Value
    x = i - 1
    a = Sheets("Sheet2").Range("E2").Value
    b = a - 1

' The variable KeyCells contains the cells that will
    ' cause an alert when they are changed.
    'Set KeyCells = Sheets("Sheet1").Cells(x, 2)
    Set KeyCells = Sheets("Sheet1").Cells(x, 2)
    Set KeyCells2 = Sheets("Sheet1").Cells(b, 2)
    Set KeyCells3 = Sheets("Sheet1").Range("B2:L28")

'MsgBox "Cell " & KeyCells.Address

If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
'MsgBox "trigger 1"
' Display a message when one of the designated cells has been
        ' changed.
        ' Place your code here.
        Call Module1.AddRows
        MsgBox Target.Value & " has been added."
     
       
ElseIf Not Application.Intersect(KeyCells2, Range(Target.Address)) _
           Is Nothing Then
'MsgBox "trigger 2"
' Display a message when one of the designated cells has been
        ' changed.
       
        ' Place your code here.
        Call Module2.AddRows2
       
       
ElseIf Not Application.Intersect(KeyCells3, Range(Target.Address)) _
           Is Nothing Then
'MsgBox "trigger 2"
' Display a message when one of the designated cells has been
        ' changed.
       
        ' Place your code here.
        MsgBox "Cell " & Target.Address & " has changed to " & Target.Value
       


End If

End Sub

Sub AddRows2()
Dim i, x As Integer
Dim lastRow, checkRow As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject



i = Sheets("Sheet2").Range("E2").Value
x = i - 1
Sheets("Sheet1").Activate
Set tbl = ActiveSheet.ListObjects("Table13")

Set lastRow = ws.Cells(i, 2)
Set checkRow = ws.Cells(x, 2)


If Not IsEmpty(checkRow.Value) Then

tbl.ListRows.Add AlwaysInsert:=True
tbl.ListRows.Add AlwaysInsert:=True
tbl.ListRows.Add AlwaysInsert:=True
tbl.ListRows.Add AlwaysInsert:=True
tbl.ListRows.Add AlwaysInsert:=True

i = i + 5
x = i - 1
Sheets("Sheet2").Range("E2").Value = i
Sheets("Sheet2").Range("F2").Value = x
MsgBox x
Exit Sub

Else

End If

Exit Sub

 

[NoSparks]

No need to keep track of things on a separate sheet.
Try something along the lines of this to count the blanks at the bottom of the first table column and add more rows if needed.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim x As Long, i As Long
Dim hdr_row As Long, last_row As Long, lastdata_row As Long
Dim tbl As ListObject

Set tbl = ActiveSheet.ListObjects(1)    '<-- first table on sheet

If Not Intersect(Target, tbl.Range) Is Nothing Then
    With tbl
        'the header row
        hdr_row = .HeaderRowRange.Cells(1).Row
        'last row of table
        last_row = .ListRows.Count + hdr_row
        'last row with data in listcolumn(1) <-- first table column
        lastdata_row = .DataBodyRange.Cells(.ListRows.Count, 1).End(xlUp).Row
        'number of existing blank rows
        x = last_row - lastdata_row
        'if less than 3 blanks add another 5
        If x < 3 Then
            Application.EnableEvents = False
            For i = 1 To 5
                .ListRows.Add
            Next i
            Application.EnableEvents = True
        End If
    End With
End If
End Sub

 

[madvogue29]

No need to keep track of things on a separate sheet.
Try something along the lines of this to count the blanks at the bottom of the first table column and add more rows if needed.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim x As Long, i As Long
Dim hdr_row As Long, last_row As Long, lastdata_row As Long
Dim tbl As ListObject

Set tbl = ActiveSheet.ListObjects(1)    '<-- first table on sheet

If Not Intersect(Target, tbl.Range) Is Nothing Then
    With tbl
        'the header row
        hdr_row = .HeaderRowRange.Cells(1).Row
        'last row of table
        last_row = .ListRows.Count + hdr_row
        'last row with data in listcolumn(1) <-- first table column
        lastdata_row = .DataBodyRange.Cells(.ListRows.Count, 1).End(xlUp).Row
        'number of existing blank rows
        x = last_row - lastdata_row
        'if less than 3 blanks add another 5
        If x < 3 Then
            Application.EnableEvents = False
            For i = 1 To 5
                .ListRows.Add
            Next i
            Application.EnableEvents = True
        End If
    End With
End If
End Sub

Thanks for the response! This is for the first table in the sheet. I will be adding tables using a script. So in a months time there may be 50 tables on the sheet. How can I modify this to update all tables on the sheet when it is almost full.

Is there a way that does ActiveSheet.ListObjects.All ??

 

[madvogue29]

Actually I added a loop and it worked ! Thank you NoSparks for all your help. I really appreciate it. Attached code below :


Private Sub Worksheet_Change(ByVal Target As Range)

Dim x As Long, i As Long
Dim hdr_row As Long, last_row As Long, lastdata_row As Long
Dim tbl As ListObject

'Loop through each sheet and table in the workbook
For Each tbl In ActiveSheet.ListObjects

'Do something to all the tables...


If Not Intersect(Target, tbl.Range) Is Nothing Then
With tbl
'the header row
hdr_row = .HeaderRowRange.Cells(1).Row
'last row of table
last_row = .ListRows.Count + hdr_row
'last row with data in listcolumn(1) <-- first table column
lastdata_row = .DataBodyRange.Cells(.ListRows.Count, 1).End(xlUp).Row
'number of existing blank rows
x = last_row - lastdata_row
'if less than 3 blanks add another 5
If x < 3 Then
Application.EnableEvents = False
For i = 1 To 5
.ListRows.Add
Next i
Application.EnableEvents = True
End If
End With
End If

Next tbl
End Sub