I have a budget template with tables for each budget category. I have buttons for users to add rows to each budget category with the rows in each category being set as a table so that my total functions work no matter how many rows are added where. But Id like users to also be able to delete rows like if they add too many or if roles change during the time the budget is changed, etc. I don't want users to be able to delete rows such as headers or totals. Protecting the rows doesn't work since the row number can change at any time with new rows being added at any time. The delete selected row code is below as well as my add a row code for the first category which is full time employee salary.
delete selected row - not good since can delete important rows
Sub DeleteSelectedRow()
Rows(ActiveCell.Row).Delete
End Sub
add row to category - good since adds rows to table to keep formulas working
Sub AddConsultant()
Dim ws As Worksheet
Dim tbl As ListObject
Set ws = ActiveSheet
Set tbl = ws.ListObjects("Consultants")
tbl.ListRows.Add
End Sub
Try this:
Sub AddConsultant()
Dim ws As Worksheet
Dim tbl As ListObject
Set ws = ActiveSheet
Set tbl = ws.ListObjects("Consultants")
tbl.ListRows.Add
End Sub
Sub DeleteSelectedRow()
Dim ws As Worksheet
Dim tbl As Range
Set ws = ActiveSheet
Set tbl = ws.ListObjects("Consultants").Range
If InRange(ActiveCell, tbl) Then
Rows(ActiveCell.Row).Delete
Else
MsgBox ("Cannot Delete")
End If
End Sub
Function InRange(Range1 As Range, Range2 As Range) As Boolean
' returns True if Range1 is within Range2
Dim InterSectRange As Range
Set InterSectRange = Application.Intersect(Range1, Range2)
InRange = Not InterSectRange Is Nothing
Set InterSectRange = Nothing
End Function
You can check whether the selection (or part of the selection) range is inside the table of interest.
For example:
Sub AddConsultant()
AddRow "Consultants"
End Sub
Sub RemoveConsultant()
RemoveSelectedRow "Consultants"
End Sub
Sub AddSite()
AddRow "Sites"
End Sub
Sub RemoveSite()
RemoveSelectedRow "Sites"
End Sub
'methods to add/remove rows from the specified table
Sub AddRow(tableName As String)
ActiveSheet.ListObjects(tableName).ListRows.Add
End Sub
Sub RemoveSelectedRow(tableName As String)
Dim rng As Range, ok As Boolean
If TypeName(Selection) = "Range" Then 'is a range selected?
'is the range in the required table?
Set rng = Application.Intersect( _
ActiveSheet.ListObjects(tableName).DataBodyRange, Selection)
If Not rng Is Nothing Then
rng.EntireRow.Delete
ok = True
End If
End If
'didn't delete anything?
If Not ok Then MsgBox "First select one or more rows in " & _
tableName & " table"
End Sub
Related
on one sheet I have a list of suppliers and their details, I have a userfrom containing a combobox that automatically populates from the list of suppliers. In the columns next to the suppliers, I have details with address, phone number etc. What I am attempting to do is after the user makes the selection, I would like the code to take the details in the adjacent columns and fill in the form. I have tried using the lookup function however I am constantly being given an error stating that the object could not be found. Below is what I have so far
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Set ws = Worksheets("RFQ Information")
'Take supplier name from combobox
'Copy row data in supplier sheet and paste (transposed) into form
Dim xRg As Range
Set xRg = Worksheets("Suppliers").Range("A2:H15")
Set Cells(53, 1) = Application.WorksheetFunction.VLookup(Me.ComboBox1.Value, xRg, 2, False)
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim SupplierName As Range
Dim SupSheet As Worksheet
Dim tbl As ListObject
Dim SupArray As Variant
Dim SupString As String
Set SupSheet = Sheets("Suppliers")
Set tbl = SupSheet.ListObjects("Table1")
Set SupplierName = tbl.ListColumns(1).DataBodyRange
SupArray = SupplierName.Value
ComboBox1.List = SupArray
UserForm1.Show
MsgBox ("done")
End Sub
I would recommend using the ComboBox Change event instead of a button, since you want the info on list selection. You can also take advantage of the ComboBox.ListIndex property to get the selected item's location in the list, and then use that to get adjacent values from your data table. Here's a quick example of how to do so:
Private Sub ComboBox1_Change()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsSup As Worksheet: Set wsSup = wb.Worksheets("Suppliers")
Dim rData As Range: Set rData = wsSup.ListObjects("Table1").DataBodyRange
Dim i As Long: i = Me.ComboBox1.ListIndex + 1
If i = 0 Then Exit Sub 'Nothing selected
'Second number is the column
' Column 1 is the Supplier
' Column 2 is the next column (phone maybe?)
' Column 3 is the column after that (address maybe?)
MsgBox rData.Cells(i, 2) & Chr(10) & _
rData.Cells(i, 3)
'Load the values you want into the necessary form controls
End Sub
I am trying to develop a custom function to check if the data in a listobject is filtered.
Public Function TestFiltered() As Boolean
Dim rngFilter As Range
Dim r As Long, f As Long
Set rngFilter = ActiveSheet.AutoFilter.Range
r = rngFilter.Rows.Count
f = rngFilter.SpecialCells(xlCellTypeVisible).Count
If r > f Then TestFiltered = True
End Function
However I am getting an error "Object variable not set" in Set rngFilter = ActiveSheet.AutoFilter.Range
All of my sheets will only have one listobject, but perhaps it is safer to somehow change the function to apply the range for the first listobject found in the activesheet?
The idea of multiplying the columns and the rows and comparing them with filterArea.SpecialCells(xlCellTypeVisible).Count is rather interesting. This is what I managed to build on it:
Public Function TestFiltered() As Boolean
Dim filterArea As Range
Dim rowsCount As Long, cellsCount As Long, columnsCount As Long
Set filterArea = ActiveSheet.ListObjects(1).Range
rowsCount = filterArea.rows.Count
columnsCount = filterArea.Columns.Count
cellsCount = filterArea.SpecialCells(xlCellTypeVisible).Count
If (rowsCount * columnsCount) > cellsCount Then
TestFiltered = True
End If
End Function
Here's another approach that tests a specific listobject. It first uses the ShowAutoFilter property of the ListObject to determine whether the AutoFilter is dislayed. If so, it then uses the FilterMode property of the AutoFilter object to determine whether it's in filter mode.
Option Explicit
Sub test()
Dim listObj As ListObject
Set listObj = Worksheets("Sheet2").ListObjects("Table1") 'change the sheet and table names accordingly
If IsListobjectFiltered(listObj) Then
MsgBox listObj.Name & " is filtered", vbInformation
Else
MsgBox listObj.Name & " is not filtered.", vbInformation
End If
End Sub
Function IsListobjectFiltered(ByVal listObj As ListObject) As Boolean
If listObj.ShowAutoFilter Then
If listObj.AutoFilter.FilterMode Then
IsListobjectFiltered = True
Exit Function
End If
End If
IsListobjectFiltered = False
End Function
Try along these lines
Dim i As Long
Dim isFiltered As Boolean
' test if AutoFilter has been turned on in the active sheet
If ActiveSheet.AutoFilterMode Then
' loop through the filters of the AutoFilter
With ActiveSheet.AutoFilter.Filters
For i = 1 To .Count
If .Item(i).On Then
isFiltered = True
Exit For
End If
Next i
End With
End If
This will also work if you are using Tables in Excel. I am using something like this in an If-Then statement to see if the number of rows in the first column matches the number of visible cells in the first column:
Dim tbl As ListObject
Set tbl = ActiveSheet.ListObjects("Table1")
If tbl.ListColumns(1).DataBodyRange.Rows.Count <> tbl.ListColumns(1).DataBodyRange.Rows.SpecialCells(xlCellTypeVisible).Count Then
'Do something if True
End If
I have three different tables that sends data too another tables in a different sheets when I push a button. However when one or two of the tables are empty I want excel to ignore the empty table/s
I've tried using this code from here but it only adds a new blank row
If WorksheetFunction.CountA(Range("Storningar")) = 1 Then
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues
End If
Tried this one also but same result:
If tblStorning.DataBodyRange Is Nothing Then
'Do something if there is no data
Else
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues 'Do something if there is data
End If
This is what the sub looks for one of the tables that sends data from table to the other one without the IF statements
Sub SkickaStorningar()
Dim tblStorning As ListObject
Dim tblStorningOuput As ListObject
Dim TargetTblLastRow As Variant
Set tblStorning = Worksheets("Rapport").ListObjects("Storningar")
Set tblStorningOutput = Worksheets("Storningar").ListObjects("StorningsTabell")
Set TargetTblLastRow = tblStorningOutput.ListRows.Add
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues
End Sub
When I push the button to send the tables I just want to send the tables that has data and ignore the ones that dont
Thanks for any help
Edit with new info:
You probably have something like this:
Sub SkickaStorningar()
Dim tblStorning As ListObject
Dim tblStorningOuput As ListObject
Dim TargetTblLastRow As Variant
Set tblStorning = Worksheets("Rapport").ListObjects("Storningar")
Set tblStorningOutput = Worksheets("Storningar").ListObjects("StorningsTabell")
Set TargetTblLastRow = tblStorningOutput.ListRows.Add ' Always adds a row
If tblStorning.ListRows.Count > 0 Then
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues
End If
End Sub
Every time you run this macro, you're adding a new blank row in your target table. You should only add a row if the if statement evaluates TRUE. Like this:
Sub SkickaStorningar()
Dim tblStorning As ListObject
Dim tblStorningOuput As ListObject
Dim TargetTblLastRow As Variant
Set tblStorning = Worksheets("Rapport").ListObjects("Storningar")
Set tblStorningOutput = Worksheets("Storningar").ListObjects("StorningsTabell")
If tblStorning.ListRows.Count > 0 Then
Set TargetTblLastRow = tblStorningOutput.ListRows.Add ' Only execute ListRows.Add if you want to add a row
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues
End If
End Sub
Try:
Option Explicit
Sub test()
Dim table As ListObject
With ThisWorkbook.Worksheets("Sheet1") '<- Change sheet name if needed
Set table = .ListObjects("tblTest") '<- Change table name
If Not table.DataBodyRange Is Nothing Then
'Code
End If
End With
End Sub
I have a problem which is probably very easy for you to help me solve.
I have two tables: Table1 and Table2. Both tables are in the same worksheet called "Budget".
I want to add a command button / a plus button, that enables a user to add a new row at the bottom of each table.
However, after trying this via the macro record function, I recognized that at some point, the new rows of Table2 are added somewhere in the middle, after having added several new rows to Table1.
Can someone please provide me with a code, that solves this issue and sort of auto-adjusts?
I have never in my life coded something.
Thank you in advance for your help!
Code from recorder:
Sub NEWROW()
'
' NEWROW Makro
'
'
Range("B12:C12").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
Try this code
Option Explicit
Sub AddRows()
Dim wks As Worksheet
Dim tbl1 As ListObject
Dim tbl2 As ListObject
Set wks = ActiveSheet
Set tbl1 = wks.ListObjects("Table1")
Set tbl2 = wks.ListObjects("Table2")
tbl1.ListRows.Add
tbl2.ListRows.Add
End Sub
Table object is explained here
Update Ok, for an absolute beginner this might be the easiest way to do it.
Sub AddRowTbl1()
Dim wks As Worksheet
Dim tbl As ListObject
Set wks = ActiveSheet
Set tbl = wks.ListObjects("Table1")
tbl.ListRows.Add
End Sub
Sub AddRowTbl2()
Dim wks As Worksheet
Dim tbl As ListObject
Set wks = ActiveSheet
Set tbl = wks.ListObjects("Table2")
tbl.ListRows.Add
End Sub
PS A more advanced user would use a function
Function tblAddRow(tblname As String, wks As Worksheet)
Dim tbl As ListObject
On Error GoTo EH
Set tbl = wks.ListObjects(tblname)
tbl.ListRows.Add
EH:
End Function
Sub Test_tblAdd()
tblAddRow "Table1", ActiveSheet
End Sub
I need assistance with selecting a Pivot table range to copy into another spreadsheet. What I need to do is copy all the rows and columns for a specific "Project WBS" value that will be searched on.
In my code below I tried using xlDataAndLabel but it only gives me the Project WBS and Pivot Items I need. It leaves out the "Description", "Employee", and "Activity Type" columns. I can't use .EntireRow.Copy because when I go to the other workbook to paste I get an error saying the size is too great.
Your help is greatly appreciated.
Max
Sub getPivotData()
Dim PvtTbl As PivotTable
Set PvtTbl = Worksheets("Aug 18 Report").PivotTables("PivotTable1")
Worksheets("Aug 18 Report").Activate
Application.PivotTableSelection = True
PvtTbl.PivotSelect "GS136.548", xlDataAndLabel
Selection.Interior.Color = vbYellow
End Sub
You could try resizing the target label range to the number of columns in the pivottable
e.g.
Option Explicit
Public Sub test()
Dim pvt As PivotTable, rng As Range
Set pvt = ActiveSheet.PivotTables(1)
With pvt.PivotFields("Project WBS").PivotItems("A").LabelRange
Set rng = Worksheets(pvt.Parent.Name).Range(.Resize(.Rows.Count, pvt.TableRange1.Columns.Count).Address)
Debug.Print rng.Address
End With
End Sub
In the following the highlighted area is the address returned by the print statement
Here is an example of referencing the pivot if it is in a different (open) workbook:
Option Explicit
Public Sub test()
Dim pvt As PivotTable, rng As Range
Dim wb As Workbook, ws As Worksheet
Set wb = Workbooks("Book3.xlsb")
Set ws = wb.Worksheets("Sheet1")
Set pvt = ws.PivotTables(1)
With pvt.PivotFields("Project WBS").PivotItems("A").LabelRange
Set rng = ws.Range(.Resize(.Rows.Count, pvt.TableRange1.Columns.Count).Address)
Debug.Print rng.Address
End With
End Sub