ListObject Tables - Essential Pointers for VBA
Created and compiled by Bhaskar. Dated 23.03.2021
Mail ID : vaskar88@gmail.com
Finding the number of filled rows in Table ListObject :
1. Create a table ListObject by first activating the sheet of the particular
table followed by setting the table object
2. Find the row number of Table header row
3. Find the row number of Table Data body Range last filled row
4. Subtract the header row number from the table last filled row number
to get the number of filled rows within the data body range
Code snippet 1:
Dim rownum As Integer
Dim HRow As Integer ‘Row number of the Header Row
Dim LastRow as Integer
Dim Rowcount as Integer
Dim Table As ListObject
‘Check table name by clicking on Formulas tab followed by clicking on Define Name
Worksheets(Range("Table3").Worksheet.Name).Activate
Set Table = Worksheets(Range("Table3").Worksheet.Name).ListObjects("Table3")
Set destcell = Range("Table3").ListObject.DataBodyRange(1,
1).End(xlDown).Offset(1, 0)
‘Row number of the Header Row
HRow = Table.HeaderRowRange.Row
‘Row number of the LastRow of Table ListObject
LastRow = Table.DataBodyRange.Cells(1,1).End(xlDown).Row
'Number of filled rows in the databody range of table
Rowcount = LastRow - HRow
References :
1. https://exceloffthegrid.com/vba-excel-tables-code/
2. https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-
excel-tables
3. https://www.dingbatdata.com/2017/11/24/referencing-listobjects-with-vba/ (Little
bit tricky. Certain excerpts may not necessarily hold true due to version changes.)
4. http://dailydoseofexcel.com/archives/2017/07/29/inconsistent-listrow-copy/ - Do
not use the listrow.copy method while copying values from table DataBodyRange
range to another.
Code snippet 2:
Sub Copy_Active_Former()
'1. A row inside the table in "ActivePlayers" sheet has to be shifted to the
"FormerPlayers" sheet
'to the next available row in a similar table.
'2. The Row copied will append to next available row in "FormerPlayers" Sheet. Rank
data of the
'copied row tone deleted, number column assigned incrementally and the table in
"FormerPlayers"
'to be sorted by number column. (All steps are in code except sorting - which did not
seem necessary)
Dim RowCount As Integer, strtrow As Integer, EndRow As Integer, HRow As Integer
Dim CopyRng As Range
Dim Table As ListObject
Dim x As Boolean
Dim y As Boolean
Dim destcell As Range
Dim UserRange As Range
Set UserRange = SelectRange
If UserRange Is Nothing Then Exit Sub
'Note cannot use If UserRange = Nothing
Dim TableName As String
TableName = "Table2"
Set Table = Range(TableName).ListObject
x = Overlap(UserRange, TableName, RowCount, strtrow, EndRow, HRow)
If x = True Then
Set CopyRng = Table.Range.Rows(CStr(strtrow - HRow + 1) & ":" &
CStr(EndRow))
CopyRng.Copy
Set destcell = Range("Table3").ListObject.DataBodyRange(1,
1).End(xlDown).Offset(1, 0)
'VBA error 1004 - select method of range class failed
destcell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Call
FormerPlayerSht(Worksheets(destcell.Worksheet.Name).Range(destcell.Address))
'Need to be careful when passing range as argument to function
Call
ActivePlayerSht(Worksheets(CopyRng.Worksheet.Name).Range(CopyRng.Address)
)
MsgBox "Transfer successfully done !!"
Else
MsgBox "Select rows overlapping with table"
End If
End Sub
Code Snippet 3:
Private Sub FormerPlayerSht(ByRef cell As Range)
'formatting adjusted in the added row
'Rank value cell cleared
'Number added incrementally (1 more than the immediate cell above)
'-----------------------------------------------------------------------------------------------------------
Dim rownum As Integer, HRow As Integer
Dim Table As ListObject
Dim LastRow1 As Range 'Last row before pasting data
'Dim LastRow2 As Range 'Last row after pasting data - Redundant
‘Check table name by clicking on Formulas tab followed by clicking on Define Name
Worksheets(Range("Table3").Worksheet.Name).Activate
Set Table = Worksheets(Range("Table3").Worksheet.Name).ListObjects("Table3")
Set LastRow1 = cell.Offset(-1, 0)
HRow = Table.HeaderRowRange.Row ‘Row number of the Header Row
rownum = cell.Offset(-1, 0).Row
Table.HeaderRowRange.Cells(1, 1).Offset(rownum - HRow).Resize(1,
Table.ListColumns.Count).Copy
Table.HeaderRowRange.Cells(1, 1).Offset(rownum - HRow + 1).PasteSpecial
Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
With Table.DataBodyRange(cell.Row - HRow, 2)
.FormulaR1C1 = "=R[-1]C+1"
.Offset(0, 1).ClearContents
End With
End Sub
