The VBA below selects all and deselects 0 and blanks on a pivot table filter, essentially refreshing the pivot table after new data is entered. It works correctly on a single sheet but the issue I have is that PivotTable1 is copied across multiple sheets and I also want this to run this on them pivot tables.
I have tried to use an array to no avail and I'm too much of a rookie to figure out how to get this to continue the same VBA onto the next sheet/pivot table.
Option Explicit
Public Sub FilterOutZeroAndBlanks()
Dim pvt As PivotTable
Set pvt = ThisWorkbook.Worksheets("Cairns Table").PivotTables("PivotTable1")
Dim pvtField As PivotField
Set pvtField = pvt.PivotFields("Quantity")
Dim item As PivotItem
Dim counter As Long
Dim targetCounter As Long
With pvtField
For Each item In .PivotItems
If item.Visible Then counter = counter + 1
Next item
If .PivotItems("0").Visible And .PivotItems("(blank)").Visible Then
targetCounter = 2
ElseIf .PivotItems("0").Visible Or .PivotItems("(blank)").Visible Then
targetCounter = 1
End If
If Not targetCounter = counter Then
.PivotItems("0").Visible = False
.PivotItems("(blank)").Visible = False
End If
End With
End Sub
Make the pivottable a parameter - then you can more-easily re-use the method by calling it from another sub:
Sub Main()
With ThisWorkbook
FilterOutZeroAndBlanks .Worksheets("Cairns Table").PivotTables("PivotTable1")
FilterOutZeroAndBlanks .Worksheets("Other Table").PivotTables("PivotTable1")
End With
End Sub
Public Sub FilterOutZeroAndBlanks(pvt As PivotTable)
Dim pvtField As PivotField
Set pvtField = pvt.PivotFields("Quantity")
Dim item As PivotItem
Dim counter As Long
Dim targetCounter As Long
With pvtField
For Each item In .PivotItems
If item.Visible Then counter = counter + 1
Next item
If .PivotItems("0").Visible And .PivotItems("(blank)").Visible Then
targetCounter = 2
ElseIf .PivotItems("0").Visible Or .PivotItems("(blank)").Visible Then
targetCounter = 1
End If
If Not targetCounter = counter Then
.PivotItems("0").Visible = False
.PivotItems("(blank)").Visible = False
End If
End With
End Sub
Related
Currently i have a perfectly functioning VBA Macro. Does everything it is required to. However, i do need some advice and help on speeding this macro up as it takes a LONG time to get things done. This macro takes aroung 5 minutes to sort through around 4k-5k populated rows, which then it hides some of the rows.
How this macro works is that it will sort through Column A, sorting through the names and comparing it to a list in Sheet1, where if the name matches the list in sheet1, it will proceed to hide the row.
Thanks in advance.
Sub FilterNameDuplicate()
Application.ScreenUpdating = False
Dim iListCount As Integer
Dim iCtr As Integer
Dim a As Long
Dim b As Long
Dim c As Long
Dim D As Long
a = Worksheets("Default").Cells(Rows.Count, "G").End(xlUp).Row
For c = 1 To a
b = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For D = 1 To b
If StrComp(Worksheets("Sheet1").Cells(D, "A"), (Worksheets("Default").Cells(c, "G")), vbTextCompare) = 0 Then
Worksheets("Default").Rows(c).EntireRow.Hidden = True
End If
Next
Next
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
All of your accesses to the worksheet really slows things down.
Much faster to use VBA arrays.
You can eliminate some of the looping by using the Range.Find method to determine if there are duplicates of the names on Default in Sheet1.
We collect the non-duplicated names (in a Collection) and then create an array to use as the argument for the Range.Filter method (which will effectively hide the entire row).
Accordingly:
Code edited to run faster using Match function
Option Explicit
Sub FilterNameDuplicate()
Dim ws1 As Worksheet, wsD As Worksheet
Dim v1 As Variant, vD As Variant, r1 As Range, rD As Range
Dim col As Collection
Dim R As Range, I As Long, arrNames() As String
With ThisWorkbook
Set ws1 = .Worksheets("Sheet1")
Set wsD = .Worksheets("Default")
End With
With ws1
Set r1 = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
v1 = r1
End With
With wsD
Set rD = Range(.Cells(1, 7), .Cells(.Rows.Count, 7).End(xlUp))
vD = rD
End With
'collect names on Default that are not on Sheet1
Set col = New Collection
With Application
For I = 2 To UBound(vD, 1)
If .WorksheetFunction.IsError(.Match(vD(I, 1), v1, 0)) Then col.Add vD(I, 1)
Next I
End With
'Filter to include those names
Application.ScreenUpdating = False
If wsD.FilterMode Then wsD.ShowAllData
ReDim arrNames(1 To col.Count)
For I = 1 To col.Count
arrNames(I) = col(I)
Next I
rD.AutoFilter field:=1, Criteria1:=arrNames, Operator:=xlFilterValues
End Sub
The main slow down is do to nested looping. Using a Collection or Dictionary for quicker lookups will speed up your code 100 times.
Sub FilterNameDuplicate()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rem Unhide all the rows
Worksheets("Default").UsedRange.EntireRow.Hidden = False
Dim Keys As Collection
Set Keys = GKeys
Dim Key As String
Dim Target As Range
With Worksheets("Default")
Set Target = Intersect(.UsedRange, .Columns("G"))
End With
If Target Is Nothing Then
MsgBox "Invalid Range"
Exit Sub
End If
Dim Cell As Range
For Each Cell In Target
Key = UCase(Cell.Value)
On Error Resume Next
Key = Keys(Key)
Cell.EntireRow.Hidden = Err.Number <> 0
On Error GoTo 0
Next
Rem We no longer need to turn ScreenUpdating back on
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
End Sub
Function GKeys() As Collection
Set GKeys = New Collection
Dim Key As String
Dim Data As Variant
Data = Worksheets("Sheet1").Range("A1").CurrentRegion.Columns(1).Value
Dim r As Long
For r = 1 To UBound(Data)
Key = UCase(Data(r, 1))
On Error Resume Next
GKeys.Add Key:=Key, Item:=""
On Error GoTo 0
Next
End Function
Trying adding in this, it speeds up by turning off screen updating, events, animations etc, this should speed it up a bit!
At the start of your code add in this sub
Call TurnOffCode
At the end of your code add in this sub
Call TurnOnCode
This is what they should both look like
Sub TurnOffCode() 'Used to turn off settings to make workbook run faster
Application.Calculation = xlCalculationManual 'Set calculations to manual
Application.ScreenUpdating = False 'Turns off screen updating
Application.EnableEvents = False 'Turns off events
Application.EnableAnimations = False 'Turns off animations
Application.DisplayStatusBar = False 'Turns off display status bar
Application.PrintCommunication = False 'Turns off print communications
End Sub
Sub TurnOnCode() 'Used to turn settings back on to normal
Application.Calculation = xlCalculationAutomatic 'Set calculations to automatic
Application.ScreenUpdating = True 'Turns on screen updating
Application.EnableEvents = True 'Turns on events
Application.EnableAnimations = True 'Turns on animations
Application.DisplayStatusBar = True 'Turns on display status bar
Application.PrintCommunication = True 'Turns on print communications
End Sub
When applying this code I am running into the issue that the top most filtered Item isn't being counted.
IE: When trying to delete the data within a Table if i have 1 entry TestEmptyTable() Returns False.
If i try to count the header as an entry and mark as >= 2 then it doesn't delete the top most entry. When it is >=1 It attempts to delete the whole sheet- When it is >1 it does nothing for the topmost entry but gets everything else. Referring to this section below when saying '>'
The Entire code is below the first code entry.
Any advise on how to get this Pesky first entry in my filtered tables?
Edit- I have learned the values that are being counted in tbl.Range.SpecialCells are not aligned with what i actually have, trying to fix that.
If tbl.Range.SpecialCells(xlCellTypeVisible).Areas.Count >= 2 Then
tblIsVisible = True
Else
If tbl.Range.SpecialCells(xlCellTypeVisible).Areas.Count < 1 Then
tblIsVisible = False
End If
End If
'In Module6
Function TestEmptyTable()
Dim tbl As ListObject
Dim tblIsVisible As Boolean
Set tbl = ActiveSheet.ListObjects(1)
If tbl.Range.SpecialCells(xlCellTypeVisible).Areas.Count >= 2 Then
tblIsVisible = True
Else
If tbl.Range.SpecialCells(xlCellTypeVisible).Areas.Count < 1 Then
tblIsVisible = False
End If
End If
TestEmptyTable = tblIsVisible
'MsgBox (TestEmptyTable)
End Function
Function DelTable()
Application.DisplayAlerts = False
If TestEmptyTable() = True Then
'MsgBox ("TestEmptyTable = True")
ActiveSheet.ListObjects("Table1").DataBodyRange.Delete
Else
'MsgBox ("TestEmptyTable= False")
End If
Application.DisplayAlerts = True
End Function
'In Module5
Sub DeleteTable()
'
'
'
'
If Module6.TestEmptyTable = True Then
Call Module6.DelTable
End If
End Sub
'in Module1
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=3, Criteria1:="MyFilterString"
MsgBox (Module6.TestEmptyTable)'Still here from trying to test what happens.
Call DeleteTable
I had some problems to understanding what you needed.
I think this code might help you achieved what you need.
Option Explicit
Sub Main()
Dim ol As ListObject: Set ol = ActiveSheet.ListObjects(1)
If isTableEmpty(ol) Then
Debug.Print "table empty"
Exit Sub
Else
Debug.Print "table not empty"
If TableHasFilters(ol) Then
Call TableDeleteFilteredRows(ol)
Else
ol.DataBodyRange.Delete
End If
End If
End Sub
Function isTableEmpty(ol As ListObject) As Boolean
If ol.ListRows.Count = 0 Then isTableEmpty = True
End Function
Function TableHasFilters(ol As ListObject) As Boolean
TableHasFilters = ol.AutoFilter.FilterMode
End Function
Sub TableFilterRestore(ol As ListObject)
If ol.AutoFilter.FilterMode Then ol.AutoFilter.ShowAllData
End Sub
Function TableVisibleRowsCount(ol As ListObject) As Integer
If ol.ListRows.Count > 0 Then
TableVisibleRowsCount = ol.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Count
End If
End Function
Sub TableDeleteFilteredRows(ol As ListObject)
Dim rCell As Range
Dim olRng As Range
Dim olRowHd As Integer
Dim lrIdx As Integer
Dim arr() As Variant
Dim i As Integer: i = 0
' Exit if table has no rows
If ol.ListRows.Count = 0 Then Exit Sub
' Set variables
Set olRng = ol.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible)
olRowHd = ol.HeaderRowRange.Row
' Count filtered rows
Dim nRows As Integer: nRows = TableVisibleRowsCount(ol)
' Redim array
ReDim arr(1 To nRows)
' Popuplate array with listrow index of visible rows
For Each rCell In olRng
' get listrow index
lrIdx = ol.ListRows(rCell.Row - olRowHd).Index
' Add item to array
i = i + 1
arr(i) = lrIdx
Next rCell
' Clear table filters
Call TableFilterRestore(ol)
' Delete rows
For i = UBound(arr) To LBound(arr) Step -1
ol.ListRows(arr(i)).Delete
Next i
End Sub
I have an Worksheet_Change macro that hides/unhides rows depending on the choice a user makes in a cell with a data validation list.
The code takes a minute to run. It's looping over c.2000 rows. I'd like it to take closer to a few seconds so it becomes a useful user tool.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Exit the routine early if there is an error
On Error GoTo EExit
'Manage Events
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Declare Variables
Dim rng_DropDown As Range
Dim rng_HideFormula As Range
Dim rng_Item As Range
'The reference the row hide macro will look for to know to hide the row
Const str_HideRef As String = "Hide"
'Define Variables
'The range that contains the week selector drop down
Set rng_DropDown = Range("rng_WeekSelector")
'The column that contains the formula which indicates if a row should
'be hidden c.2000 rows
Set rng_HideFormula = Range("rng_HideFormula")
'Working Code
'Exit sub early if the Month Selector was not changed
If Not Target.Address = rng_DropDown.Address Then GoTo EExit
'Otherwise unprotect the worksheet
wks_DailyPlanning.Unprotect (str_Password)
'For each cell in the hide formula column
For Each rng_Item In rng_HideFormula
With rng_Item
'If the cell says "hide"
If .Value2 = str_HideRef Then
'Hide the row
.EntireRow.Hidden = True
Else
'Otherwise show the row
.EntireRow.Hidden = False
End If
End With
'Cycle through each cell
Next rng_Item
EExit:
'Reprotect the sheet if the sheet is unprotected
If wks_DailyPlanning.ProtectContents = False Then wks_DailyPlanning.Protect (str_Password)
'Clear Events
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I have looked at some links provided by other users on this website and I think the trouble lies in the fact I'm having to iterate through each row individually.
Is it possible to create something like an array of .visible settings I can apply to the entire range at once?
I'd suggest copying your data range to a memory-based array and checking that, then using that data to adjust the visibility of each row. It minimizes the number of interactions you have with the worksheet Range object, which takes up lots of time and is a big performance hit for large ranges.
Sub HideHiddenRows()
Dim dataRange As Range
Dim data As Variant
Set dataRange = Sheet1.Range("A13:A2019")
data = dataRange.Value
Dim rowOffset As Long
rowOffset = IIf(LBound(data, 1) = 0, 1, 0)
ApplicationPerformance Flag:=False
Dim i As Long
For i = LBound(data, 1) To UBound(data, 1)
If data(i, 1) = "Hide" Then
dataRange.Rows(i + rowOffset).EntireRow.Hidden = True
Else
dataRange.Rows(i + rowOffset).EntireRow.Hidden = False
End If
Next i
ApplicationPerformance Flag:=True
End Sub
Public Sub ApplicationPerformance(ByVal Flag As Boolean)
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
End Sub
Another possibility:
Dim mergedRng As Range
'.......
rng_HideFormula.EntireRow.Hidden = False
For Each rng_Item In rng_HideFormula
If rng_Item.Value2 = str_HideRef Then
If Not mergedRng Is Nothing Then
Set mergedRng = Application.Union(mergedRng, rng_Item)
Else
Set mergedRng = rng_Item
End If
End If
Next rng_Item
If Not mergedRng Is Nothing Then mergedRng.EntireRow.Hidden = True
Set mergedRng = Nothing
'........
to increase perfomance you can populate dictionary with range addresses, and hide or unhide at once, instead of hide/unhide each particular row (but this is just in theory, you should test it by yourself), just an example:
Sub HideHiddenRows()
Dim cl As Range, x As Long
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
x = Cells(Rows.Count, "A").End(xlUp).Row
For Each cl In Range("A1", Cells(x, "A"))
If cl.Value = 0 Then dic.Add cl.Address(0, 0), Nothing
Next cl
Range(Join(dic.keys, ",")).EntireRow.Hidden = False
End Sub
demo:
I need help with the below code and pivot table.
I run my script on a weekly basis and each time I need time select the last available item in the below pivot tables (PivotTable1, PivotTable2 and PivotTable3):
I tried the below code but it doesn't work:
Dim pi As PivotItem
Dim lLoop As Long
Dim pt As PivotTable
Dim lCount As Long
Dim lWeeks As Long
On Error Resume Next
lWeeks = 1
If lWeeks = 0 Then Exit Sub
Application.ScreenUpdating = False
Set pt = ActiveSheet.PivotTables("PivotTable1")
For Each pi In pt.PivotFields("Week").PivotItems
pi.Visible = False
Next pi
With pt.PivotFields("Week")
For lLoop = .PivotItems.Count To 1 Step -1
.PivotItems(lLoop).Visible = True
lCount = lCount + 1
If lCount = lWeeks Then Exit For
Next lLoop
End With
On Error GoTo 0
Application.ScreenUpdating = True
I also tried the below but it's still not working:
Sheets("Pivot").Select
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
ActiveSheet.PivotTables("PivotTable1").PivotFields("ExtractDate"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable1").PivotFields("ExtractDate").CurrentPage _
= ThisWorkbook.Worksheets("Pivot").Range("B2").Value
In this case I'm having the Runtime Error 1004: Unable to get the PivotTables property of the Worksheet class.
Can you please advise how to modify the above codes to select the last available item in the 'Week' filter?
Also, how to modify this code to select the last value for these 3 pivot tables?
Thanks in advance.
You can set the current filter page with the name of the last (or first) PivotItem:
With ActiveSheet.PivotTables("PivotTable1").PageFields("Week")
.ClearManualFilter ' or ClearAllFilters
.AutoSort xlAscending, .SourceName
.CurrentPage = .Pivotitems(.Pivotitems.Count).Name
If .CurrentPage = "(blank)" And .Pivotitems.Count > 1 Then
.CurrentPage = .Pivotitems(.Pivotitems.Count - 1).Name
End If
End With
If the last entry is blank, it selects the previous one.
If you need the other end of your date range, just change xlAscending to xlDescending.
You can loop over all PivotTables in a worksheet and set each filter to the last page by this:
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
For Each pt In ActiveSheet.PivotTables
pt.RefreshTable
' Set pf = pt.PageFields("Week")
For Each pf In pt.PageFields
pf.ClearManualFilter ' or ClearAllFilters
pf.EnableMultiplePageItems = True
pf.AutoSort xlAscending, pf.SourceName
pf.CurrentPage = pf.Pivotitems(pf.Pivotitems.Count).Name
If pf.CurrentPage = "(blank)" And pf.Pivotitems.Count > 1 Then
pf.CurrentPage = pf.Pivotitems(pf.Pivotitems.Count - 1).Name
End If
Next pf
Next pt
At least 1 item has to remain visible, so you can't loop over all items and set them .Visible = False. A loop over all except the last PivotItem should work, but is too slow.
I added a .RefreshTable to refresh the data in your PivotTable. If there are still wrong informations, you can refresh the PivotCache of your workbook additionally:
Dim pc As PivotCache
For Each pc In ActiveWorkbook.PivotCaches
pc.MissingItemsLimit = xlMissingItemsNone
pc.Refresh
Next pc
I want to add data to last row in each table in each worksheet when the worksheet is protected.
I have this code in ThisWorkbook to protect the worksheets
Private Sub Workbook_Open()
Dim wSheet As Worksheet
For Each wSheet In Worksheets
wSheet.Protect Password:="Secret", _
UserInterFaceOnly:=True
Next wSheet
End Sub
and the following code to add the data. It throws
Error 1004 "Application-defined or Object-defined error"
at the Set newrow1 = tbl.ListRows.Add when the worksheet is protected.
Sub AddDataToTable()
Application.ScreenUpdating = False
Dim MyValue As String
Dim sh As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim ws5 As Worksheet
Set ws1 = Sheets("Setting")
Set ws2 = Sheets("R_Buy")
Set ws3 = Sheets("R_Sell")
Set ws4 = Sheets("S_Buy")
Set ws5 = Sheets("S_Sell")
Dim tbl As ListObject
Dim tb2 As ListObject
Dim tb3 As ListObject
Dim tb4 As ListObject
Dim tb5 As ListObject
Set tbl = ws1.ListObjects("T_Setting")
Set tb2 = ws2.ListObjects("T_R_Buy")
Set tb3 = ws3.ListObjects("T_R_Sell")
Set tb4 = ws4.ListObjects("T_S_Buy")
Set tb5 = ws5.ListObjects("T_S_Sell")
Dim newrow1 As ListRow
Dim newrow2 As ListRow
Dim newrow3 As ListRow
Dim newrow4 As ListRow
Dim newrow5 As ListRow
MyValue = InputBox("Add To Table, this cannot be undone")
'check if user clicked Cancel button and, if appropriate, execute statements
If StrPtr(MyValue) = 0 Then
'display message box confirming that user clicked Cancel button
MsgBox "You clicked the Cancel button"
'check if user entered no input and, if appropriate, execute statements
ElseIf MyValue = "" Then
'display message box confirming that user entered no input
MsgBox "There is no Text Input"
Else
Set newrow1 = tbl.ListRows.Add
With newrow1
.Range(1) = MyValue
End With
Set newrow2 = tb2.ListRows.Add
With newrow2
.Range(1) = MyValue
End With
Set newrow3 = tb3.ListRows.Add
With newrow3
.Range(1) = MyValue
End With
Set newrow4 = tb4.ListRows.Add
With newrow4
.Range(1) = MyValue
End With
Set newrow5 = tb5.ListRows.Add
With newrow5
.Range(1) = MyValue
End With
End If
Application.ScreenUpdating = True
End Sub
That's an issue with Excel that it doesn't allow to edit tables in UserInterFaceOnly:=True mode. Unfortunately, the only workaround I've found is to unprotect before any table methods are applied and then reprotect after:
.Unprotect Password:=SHEET_PW 'unprotect sheet
'edit table
.Protect Password:=SHEET_PW, UserInterFaceOnly:=True 'reprotect
Additionally I suggest the following improvement to shorten your code:
Use arrays Dim tbl(1 To 5) instead of multiple variables tbl1, tbl2, tbl3, …
Or better use an array to list your worksheet names only.
Use more descriptive variable names (makes your life easier to maintain and read the code)
If your table names are always T_ followed by the worksheet name you can easily generate them out of your worksheet name.
Use a constant for your worksheet password SHEET_PW to have it stored in only one place (easier to change, prevents typos).
Use loops to do repetitive things.
So we end up with:
Option Explicit
Const SHEET_PW As String = "Secret" 'global password for protecting worksheets
Public Sub AddDataToTableImproved()
Dim AddValue As String
AddValue = InputBox("Add To Table, this cannot be undone")
If StrPtr(AddValue) = 0 Then 'cancel button
MsgBox "You clicked the Cancel button"
Exit Sub
ElseIf AddValue = "" Then 'no input
MsgBox "There is no Text Input"
Exit Sub
End If
Dim NewRow As ListRow
Dim SheetNameList() As Variant
SheetNameList = Array("Setting", "R_Buy", "R_Sell", "S_Buy", "S_Sell")
Dim SheetName As Variant
For Each SheetName In SheetNameList
With ThisWorkbook.Worksheets(SheetName)
.Unprotect Password:=SHEET_PW 'unprotect sheet
Set NewRow = .ListObjects("T_" & SheetName).ListRows.Add
NewRow.Range(1) = AddValue
.Protect Password:=SHEET_PW, UserInterFaceOnly:=True 'reprotect it
End With
Next SheetName
End Sub
A bit late to help the original OP but hopefully this will help other readers.
There is indeed an issue with the ListObject functionality when the worksheet is protected even if the UserInterFaceOnly flag is set to True.
However, we can still use the Range and Application functionality and we can actually work around most of the use cases with the exception of 2 edge cases:
We want to insert immediately after the header row AND the sheet is protected AND the headers are off (.ShowHeaders is False) - I don't think there is any solution to this but to be honest I wonder why would one have the headers off. Not to mention it's a really rare case to meet all 3 criterias.
The table has no rows AND the sheet is protected AND the headers are off. In this case the special 'insert' row cannot easily be turned into a 'listrow' but it can be done with a few column and row inserts - not worth the trouble though as this is potentially rare in real life use.
Here is the code that I came up with:
Option Explicit
Option Private Module
Private Const MODULE_NAME As String = "LibExcelListObjects"
'*******************************************************************************
'Adds rows to a ListObject and returns the corresponding added Range
'Parameters:
' - tbl: the table to add rows to
' - [rowsToAdd]: the number of rows to add. Default is 1
' - [startRow]: the row index from where to start adding. Default is 0 in
' which case the rows would be appended at the end of the table
' - [doEntireSheetRow]:
' * TRUE - adds entire rows including left and right of the target table
' * FALSE - adds rows only below the table bounds shifting down (default)
'Raises error:
' - 5: if 'rowsToAdd' is less than 1
' - 9: if 'startRow' is invalid
' - 91: if 'tbl' is not set
' - 1004: if adding rows failed due to worksheet being protected while the
' UserInterfaceOnly flag is set to False
'*******************************************************************************
Public Function AddListRows(ByVal tbl As ListObject _
, Optional ByVal rowsToAdd As Long = 1 _
, Optional ByVal startRow As Long = 0 _
, Optional ByVal doEntireSheetRow As Boolean = False _
) As Range
Const fullMethodName As String = MODULE_NAME & ".AddListRows"
Dim isSuccess As Boolean
'
If tbl Is Nothing Then
Err.Raise 91, fullMethodName, "Table object not set"
ElseIf startRow < 0 Or startRow > tbl.ListRows.Count + 1 Then
Err.Raise 9, fullMethodName, "Invalid start row index"
ElseIf rowsToAdd < 1 Then
Err.Raise 5, fullMethodName, "Invalid number of rows to add"
End If
If startRow = 0 Then startRow = tbl.ListRows.Count + 1
'
If startRow = tbl.ListRows.Count + 1 Then
isSuccess = AppendListRows(tbl, rowsToAdd, doEntireSheetRow)
Else
isSuccess = InsertListRows(tbl, rowsToAdd, startRow, doEntireSheetRow)
End If
If Not isSuccess Then
If tbl.Parent.ProtectContents And Not tbl.Parent.ProtectionMode Then
Err.Raise 1004, fullMethodName, "Parent sheet is macro protected"
Else
Err.Raise 5, fullMethodName, "Cannot append rows"
End If
End If
Set AddListRows = tbl.ListRows(startRow).Range.Resize(RowSize:=rowsToAdd)
End Function
'*******************************************************************************
'Utility for 'AddListRows' method
'Inserts rows into a ListObject. Does not append!
'*******************************************************************************
Private Function InsertListRows(ByVal tbl As ListObject _
, ByVal rowsToInsert As Long _
, ByVal startRow As Long _
, ByVal doEntireSheetRow As Boolean) As Boolean
Dim rngInsert As Range
Dim fOrigin As XlInsertFormatOrigin: fOrigin = xlFormatFromLeftOrAbove
Dim needsHeaders As Boolean
'
If startRow = 1 Then
If Not tbl.ShowHeaders Then
If tbl.Parent.ProtectContents Then
Exit Function 'Not sure possible without headers
Else
needsHeaders = True
End If
End If
fOrigin = xlFormatFromRightOrBelow
End If
'
Set rngInsert = tbl.ListRows(startRow).Range.Resize(RowSize:=rowsToInsert)
If doEntireSheetRow Then Set rngInsert = rngInsert.EntireRow
'
On Error Resume Next
If needsHeaders Then tbl.ShowHeaders = True
rngInsert.Insert xlShiftDown, fOrigin
If needsHeaders Then tbl.ShowHeaders = False
InsertListRows = (Err.Number = 0)
On Error GoTo 0
End Function
'*******************************************************************************
'Utility for 'AddListRows' method
'Appends rows to the bottom of a ListObject. Does not insert!
'*******************************************************************************
Private Function AppendListRows(ByVal tbl As ListObject _
, ByVal rowsToAppend As Long _
, ByVal doEntireSheetRow As Boolean) As Boolean
If tbl.ListRows.Count = 0 Then
If Not UpgradeInsertRow(tbl) Then Exit Function
If rowsToAppend = 1 Then
AppendListRows = True
Exit Function
End If
rowsToAppend = rowsToAppend - 1
End If
'
Dim rngToAppend As Range
Dim isProtected As Boolean: isProtected = tbl.Parent.ProtectContents
'
On Error GoTo ErrorHandler
If isProtected And tbl.ShowTotals Then
Set rngToAppend = tbl.TotalsRowRange
ElseIf isProtected Then
Set rngToAppend = AutoExpandOneRow(tbl)
Else
Set rngToAppend = tbl.Range.Rows(tbl.Range.Rows.Count + 1)
End If
'
Set rngToAppend = rngToAppend.Resize(RowSize:=rowsToAppend)
If doEntireSheetRow Then Set rngToAppend = rngToAppend.EntireRow
rngToAppend.Insert xlShiftDown, xlFormatFromLeftOrAbove
'
If isProtected And tbl.ShowTotals Then 'Fix formatting
tbl.ListRows(1).Range.Copy
With tbl.ListRows(tbl.ListRows.Count - rowsToAppend + 1).Range
.Resize(RowSize:=rowsToAppend).PasteSpecial xlPasteFormats
End With
ElseIf isProtected Then 'Delete the autoExpand row
tbl.ListRows(tbl.ListRows.Count).Range.Delete xlShiftUp
Else 'Resize table
tbl.Resize tbl.Range.Resize(tbl.Range.Rows.Count + rowsToAppend)
End If
AppendListRows = True
Exit Function
ErrorHandler:
AppendListRows = False
End Function
'*******************************************************************************
'Utility for 'AppendListRows' method
'Transforms the Insert row into a usable ListRow
'*******************************************************************************
Private Function UpgradeInsertRow(ByVal tbl As ListObject) As Boolean
If tbl.InsertRowRange Is Nothing Then Exit Function
If tbl.Parent.ProtectContents And Not tbl.ShowHeaders Then
Exit Function 'Not implemented - can be done using a few inserts
Else
Dim needsHeaders As Boolean: needsHeaders = Not tbl.ShowHeaders
'
If needsHeaders Then tbl.ShowHeaders = True
tbl.InsertRowRange.Insert xlShiftDown, xlFormatFromLeftOrAbove
If needsHeaders Then tbl.ShowHeaders = False
End If
UpgradeInsertRow = True
End Function
'*******************************************************************************
'Utility for 'AppendListRows' method
'Adds one row via auto expand if the worksheet is protected and totals are off
'*******************************************************************************
Private Function AutoExpandOneRow(ByVal tbl As ListObject) As Range
If Not tbl.Parent.ProtectContents Then Exit Function
If tbl.ShowTotals Then Exit Function
'
Dim ac As AutoCorrect: Set ac = Application.AutoCorrect
Dim isAutoExpand As Boolean: isAutoExpand = ac.AutoExpandListRange
Dim tempRow As Range: Set tempRow = tbl.Range.Rows(tbl.Range.Rows.Count + 1)
'
If Not isAutoExpand Then ac.AutoExpandListRange = True
tempRow.Insert xlShiftDown, xlFormatFromLeftOrAbove
Set AutoExpandOneRow = tempRow.Offset(-1, 0)
Const arbitraryValue As Long = 1 'Must not be Empty/Null/""
AutoExpandOneRow.Value2 = arbitraryValue 'AutoExpand is triggered
If Not isAutoExpand Then ac.AutoExpandListRange = False 'Revert if needed
End Function
Assuming tbl is a variable holding the table, we can use the above like this:
AddListRows tbl 'Adds 1 row at the end
AddListRows tbl, 5 'Adds 5 rows at the end
AddListRows tbl, 3, 2 'Inserts 3 rows at index 2
AddListRows tbl, 1, 3, True 'Insert one row at index 3 but for the whole sheet
As long as the UserInterfaceOnly flag is set to True the above will work except the 2 edge cases I mentioned at the beginning of the answer. Of course, the operation would fail if there is another ListObject immediately below the table we want to insert into but that would fail anyway even if the sheet was unprotected.
One nice advantage is that the AddListRows method above returns the range that was inserted so that it can be used to write data immediately after the rows were added.