VBA to auto populate a table from data entered in another table - excel

I'm an electrical contractor and I made a worksheet to help me bid projects.
Say I'm bidding on wiring a new house. I have broken down each task "outlet"/"Switch" to materials and labor needed for each task. Those materials are then multiplied by the quantity needed and populate 3 different tables automatically.
Here is the process: (24 outlets are needed for this job)
"Bid Cut Sheet" Sheet where quantities of specific tasks are entered.
"Job List" Tasks are broken down into materials needed for that task, multiplied by the quantity entered in "Bid Cut Sheet"
"Material Sheet" Total of all material needed for the job in 3 different tables/stages of the project
What I am trying to do is populate rows in EACH table where materials are needed. Essentially consolidate the data in EACH table by eliminating with quantities of 0 and ADDING rows with quantities >0 and fill down rows with material needed: updating every time data is entered in the "Bid Cut Sheet"
This code eliminates values of 0 after I run the code, but does not update data entered in the "bid cut sheet" after I run the code. Also, I would like this to be imbedded in the workbook so I dont have to run the code each time I use the workbook.
Sub DeleteRowsBasedonCellValue()
'Declare Variables
Dim i As Long, LastRow As Long, Row As Variant
Dim listObj As ListObject
Dim tblNames As Variant, tblName As Variant
Dim colNames As Variant, colName As Variant
'Names of tables
tblNames = Array("Rough_Material", "Trim_Material", "Service_Material")
colNames = Array("Rough", "Trim", "Service")
'Loop Through Tables
For i = LBound(tblNames) To UBound(tblNames)
tblName = tblNames(i)
colName = colNames(i)
Set listObj = ThisWorkbook.Worksheets("MaterialSheet").ListObjects(tblName)
'Define First and Last Rows
LastRow = listObj.ListRows.Count
'Loop Through Rows (Bottom to Top)
For Row = LastRow To 1 Step -1
With listObj.ListRows(Row)
If Intersect(.Range, _
listObj.ListColumns(colName).Range).Value = 0 Then
.Delete
End If
End With
Next Row
Next i
End Sub
This is what it looks like after running the code, it works one time but does not update.

If I understand your question correctly, what you are looking for is something like this:
Sub DeleteRowsBasedonCellValue()
'Declare Variables
Dim LastRow As Long, FirstRow As Long
Dim Row As Long
Dim columns As Variant, column As Variant
columns = Array("A", "D", "G")
With ThisWorkbook.Worksheets("Sheet1") '<- type the name of the Worksheet here
'Define First and Last Rows
FirstRow = 1
LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'Loop Through Columns
For Each column In columns
'Loop Through Rows (Bottom to Top)
For Row = LastRow To FirstRow Step -1
If .Range(column & Row).Value = 0 Then
.Range(column & Row).Resize(1, 2).Delete xlShiftUp
End If
Next Row
Next column
End With
End Sub
Test it out and see if this does what you want.
Alternatively, it might be wiser to be more explicit and make the code more flexible. If your tables are actually formatted as tables, you can also loop over these so-called ListObjects. That way, if you insert columns/rows in the future, the code won't break.
To do this, you could use code like this:
Sub DeleteRowsBasedonCellValue()
'Declare Variables
Dim i As Long, LastRow As Long, Row As Variant
Dim listObj As ListObject
Dim tblNames As Variant, tblName As Variant
Dim colNames As Variant, colName As Variant
'The names of your tables
tblNames = Array("Rough_Materials", "Trim_Materials", "Service_Materials")
colNames = Array("quantity_rough", "quantity_trim", "quantity_service")
'The name of the column the criterion is applied to inside each table
'Loop Through Tables
For i = LBound(tblNames) To UBound(tblNames)
tblName = tblNames(i)
colName = colNames(i)
Set listObj = ThisWorkbook.Worksheets("Sheet1").ListObjects(tblName)
'Define First and Last Rows '^- the name of the Worksheet
LastRow = listObj.ListRows.Count
'Loop Through Rows (Bottom to Top)
For Row = LastRow To 1 Step -1
With listObj.ListRows(Row)
If Intersect(.Range, _
listObj.ListColumns(colName).Range).Value = 0 Then
.Delete
End If
End With
Next Row
Next i
End Sub
Edit in response to your comment:
Make sure your table is actually formatted as a table and has been given the right name! You can also change the table names in your code to your liking in the line tblNames = Array("Rough_Materials", "Trim_Materials", "Service_Materials"). Also, the column names have to be correct/you should adapt them in the code: colNames = Array("quantity_rough", "quantity_trim", "quantity_service")

Related

Inserting rows at end of excel table macro - Method range of object _global failed

Background: I have a table in excel that data will get added to over time, and to give my coworkers (who, while lovely, do not like tinkering with things in excel in fear of messing something up) an easy option for expanding the table if it fills when I'm not around, I wanted to add a macro button to add more lines to the table and fill in the formatting (some cells have IF functions in & most have conditional formatting). The idea is they can fill up to but not including the last line of the table, then hit the button and it will add 20 or so new lines before the last line of table and copy the formatting of the last line into them.
So far this is my code:
Sub Add_Rows()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject
Set tbl = ws.ListObjects("Table1")
x = tbl.Range.Rows.Count
Range(x - 1, x + 19).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
End Sub
I am getting a "Run time error '1004'" "Method range of object _global failed" message when I try clicking the button, and it highlights the "insert" line as being the issue. I am new to vba so any advice is welcome. If my code is utter nonsense then an alternative direction would be appreciated.
Also this is the second version, my first looped Rows.Add which worked, but was taking a few seconds so my hope was inserting 20 would be faster than adding 1 20 times!
Try this.
Sub Add_Rows()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject
Dim lastRow As Range, newRng As Range
Dim newRows As Integer: newRows = 20
Set tbl = ws.ListObjects("Table1")
' Last row
On Error GoTo resizeOnly ' Listrows = 0
Set lastRow = tbl.ListRows(tbl.ListRows.Count).Range
On Error GoTo 0
' range of new rows
Set newRng = tbl.ListRows(tbl.ListRows.Count).Range.Resize(newRows).Offset(1)
' resize table
tbl.Resize tbl.Range.Resize(tbl.Range.Rows.Count + newRows, tbl.Range.Columns.Count)
' copy last format to new rows
lastRow.Copy
newRng.PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
Exit Sub
resizeOnly:
' resize table
tbl.Resize tbl.Range.Resize(tbl.Range.Rows.Count + newRows, tbl.Range.Columns.Count)
End Sub
If you have no data below the table, you can just assign values to the rows immediately after the table. The table will automatically expand to encompass the new rows, as long as at least one cell in each row, has well defined data.
' Insert 3 new rows into the listoject
' We assume the ListObject already contains data
Public Sub Test(Lob As ListObject)
Dim Sht As Worksheet
Dim StartRow As Long, StartCol As Long, NumCols As Long
Dim Lst As Variant
Dim Rng As Range
' Allocate 3 new rows
NumCols = Lob.ListColumns.Count
ReDim Lst(1 to 3, 1 to NumCols)
' Get the first column of and the first row following the list table
StartCol = Lob.Range.Column
StartRow = Lob.Range.row + Lob.Range.Rows.Count
' Create a range big enough to hold the data, immediately under the last row of the table.
Set Sht = Lob.Parent
Set Rng = Sht.Cells(StartRow, StartCol).Resize(UBound(Lst), UBound(Lst, 2))
' Add some data to the new rows
Lst(1, 1) = "Test1"
Lst(2, 1) = "Test2"
Lst(3, 1) = "Test3"
' Copy data to the destination
Rng = Lst
End Sub
If the list object does not contain data, ie Lob.ListRows.Count = 0, then write data after the header otherwise write it after the last rows.
There are some mistakes in your code:
"Range(x , y)" will cause an error, when x and y are integers. If you want to refer to a cell. Try Cells(x, y). Or Range(Cells(x1, y1), Cells(x2, y2)) to refer to more cells.
And Resize() takes two arguments, and returns a range - it does not affect anything on the sheet.
See also how to insert rows if you want:
Excel Range.Insert:
Example from the doc:
With Range("B2:E5")
.Insert xlShiftDown
' Optionally clear formats, which you do not want, if you add to
' a table with well defined data and formats.
.ClearFormats
End With
The number of the rows inserted, will equal the number of rows in the range we call Insert on.

Finding the occurrence across multiple sheets but with a twist

I wanted to find the number of sick leave of the workers per month. I know that can be achieved easily with =Ifs (), but as you can see from this screenshot:
the sheets may contain the data of other months (late December and early February in this case). There are 12 sheets in total, each contains one month of the year.
I want to write a function that can count the numbers of holidays given by "休息" for each month for each person.
The difficulty is that:
The roaster changes every month and cell position of each person changes, the other problem is:
As mentioned above, each sheet may contain data of other months, which implies the function has to refer to other sheets to count these leaves as well.
Can this be achieved with excel intrinsic functions or should this be done with VBA?
It is real difficult and lot of assumption, to try and understand the problem in unknown language and scanty details. However the solution worked out based of a number of assumption and hope to offer only broad outline to be modified as real time solution according to actual layout of the working file
Assumptions:
Names are in column B
Names start at row 11
For trial only rows up to 35 are used
Days span from column D to AF (Approx)
Column AL is free and used for Countif formula
For solution with excel formulas
Populate column AL of all the monthly sheets with formula
=COUNTIF(D11:AE11,"休息")
In a blank Sheet named “Main” populate column B with list of all the names (may be starting from row 11)
Now Column C representing Month1 may be added with formula
=IF(ISNA(MATCH($B11,Sheet1!$B$11:$B$35,0)), "",INDEX(Sheet1!$AL$11:$AL$35,MATCH($B11,Sheet1!$B$11:$B$35,0),1))
Similarly Column D representing Month1 may be added with formula
=IF(ISNA(MATCH($B12,Sheet2!$B$11:$B$35,0)), "",INDEX(Sheet2!$AL$11:$AL$35,MATCH($B12,Sheet2!$B$11:$B$35,0),1))
And similarly add formula to all the 12 columns pointing towards 12 sheets in the workbook and the create a summation in next blank column
Result Sheet Layout - Main and Month sheets Layout
VBA solution
Add one blank sheet Named “MainVBA” containing list of all the names in the column B starting from row 11 as done in sheet named “Main”. Alternatively this employee list could be created by using dictionary object and collecting all unique names (case sensitive) from all the monthly sheets. For using this code please add reference to “Microsoft Scripting runtime”. (VBA window – Tools – Reference)
Code:
Sub MakeList()
Dim MnWs As Worksheet, Ws As Worksheet
Dim Srw As Long, S1rw As Long
Dim Erw As Long, E1rw As Long
Dim Xname As String
Dim TRw As Long
Dim Cnt As Long
Dim Dict As Dictionary
Set MnWs = ThisWorkbook.Sheets("MainVBA")
Srw = 11 'Starting Row in Result sheet Named "MainVBA"
Erw = MnWs.Cells(Rows.Count, "B").End(xlUp).Row 'Last Row in Result sheet Named "MainVBA"
MnWs.Range("B" & Srw & ":B" & Erw).ClearContents ' Delete last row
Set Dict = New Dictionary
'Get Names from monthly sheets
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "MainVBA" And Ws.Name <> "Main" Then ' Consider all sheets Other than specified two having sick leave data
S1rw = 11
E1rw = Ws.Cells(Rows.Count, "B").End(xlUp).Row 'Last Row in Month sheet
For TRw = S1rw To E1rw
Xname = Ws.Cells(TRw, "B").Value
If Dict.Exists(Xname) = False Then
'Debug.Print Ws.Name, TRw, Xname
Dict.Add Xname, 1
End If
Next
End If
Next Ws
'create list in Sheet "MainVBA" Column B from dictionary
For Cnt = 0 To Dict.Count - 1
MnWs.Cells(Cnt + 11, "B").Value = Dict.Keys(Cnt)
Next
Set Dict = Nothing
End Sub
Code for calculating sick leave count month wise. I used Range B1 to hold the string "休息" (as I refrained to tweak the regional settings etc) , it may be used directly in your VBA module.
Option Explicit
Sub test()
Dim MnWs As Worksheet, Ws As Worksheet
Dim Srw As Long, S1rw As Long, Scol As Long
Dim Erw As Long, E1rw As Long, Ecol As Long
Dim Rw As Long, Col As Long, Xname As String, ChineseStr As String
Dim TRw As Long, XRw As Long, Have As Boolean
Dim Rng As Range, Cnt As Long
Set MnWs = ThisWorkbook.Sheets("MainVBA")
ChineseStr = MnWs.Range("B1").Value 'May use string directly with quotes
Srw = 11 'Starting Row in Result sheet Named "MainVBA"
Erw = MnWs.Cells(Rows.Count, "B").End(xlUp).Row 'Last Row in Result sheet Named "MainVBA"
Scol = 3 'Starting Col Month1 in Result sheet Named "MainVBA"
Ecol = 3 + 11 'End Col Month12 in Result sheet Named "MainVBA"
For Rw = Srw To Erw
Xname = MnWs.Cells(Rw, "B").Value
Col = Scol
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "MainVBA" And Ws.Name <> "Main" Then ' Consider all sheets Other thah specified two having Sick leave data
S1rw = 11
E1rw = Ws.Cells(Rows.Count, "B").End(xlUp).Row 'Last Row in Month sheet
XRw = 0
For TRw = S1rw To E1rw
If Ws.Cells(TRw, "B").Value = Xname Then
XRw = TRw
Exit For
End If
Next
Cnt = 0
If XRw > 0 Then
'Debug.Print Xname, Ws.Name, TRw
Set Rng = Ws.Range("D" & XRw & ":AF" & XRw) ' Col D to AF condsidered having sick leave data
Cnt = Application.WorksheetFunction.CountIf(Rng, ChineseStr) 'sum of month sick leave
End If
MnWs.Cells(Rw, Col).Value = Cnt
Col = Col + 1
End If
Next Ws
Next Rw
End Sub
To make this code working, it may be required to modify all the sheets details like sheets name, row, column details etc. Feel free to feedback if code is some where near to your objective and actual scenario.

Variable out of range or failed to be recognized

I need some advice for my code. I really appreciate if some members can edit my code. Thanks
My code below is looking for the name on column B and copy the result on another sheet if 2 conditions met:
- The row.value on column G = "ongoing"
- The row.value on column C = "HP"
When I run this code, got an error-message box "Range of Object"_Worksheet failed.
I am trying to change the set "mytable to ShSReturn.ListObject ("Survey Return")" with mytable as Range, another message error "Subscription out of range"
Sub LOf()
Dim cell As Variant
Dim myrange As Long, lastrow As Long, finalrow As Long, resultrow As Long
Dim mytable As Range
lastrow = ShSReturn.Range("G" & ShSReturn.Rows.Count).End(xlUp).Row
finalrow = ShSReturn.Range("C" & ShSReturn.Rows.Count).End(xlUp).Row
resultrow = ShSReturn.Range("B" & ShSReturn.Rows.Count).End(xlUp).Row
Set mytable = ShSReturn.ListObjects("Survey Return")
cell = 7
For Each cell In mytable
If mytable.Cells(cell, lastrow).Value = "Ongoing" _
And mytable.Cells(cell, finalrow).Value = "HP" Then
mytable.Cells(cell, resultrow).Copy
ShPPT.Cells(cell, 17).PasteSpecial xlPasteValues
resultrow = resultrow + 1
End If
Next cell
End Sub
I think there's some confusion about the nature of your ListObject, as specified in your original code (see comments to the question). When you select a bunch of cells and go to Insert -> Table, then as well as the table object, Excel defines a Range with the name of that table: a named Range. This Range may be referenced directly in VBA as such:
Set mytable = Range("Table1")
Note that Range names may not contain spaces
On the assumption that you have a named Range, it might be something like this:
Sub LOf()
Dim myrange As Long, lastrow As Long, finalrow As Long, resultrow As Long
Dim mytable As Range
lastrow = ShSReturn.Range("G" & ShSReturn.Rows.Count).End(xlUp).Row
finalrow = ShSReturn.Range("C" & ShSReturn.Rows.Count).End(xlUp).Row
resultrow = ShSReturn.Range("B" & ShSReturn.Rows.Count).End(xlUp).Row
Set mytable = ActiveSheet.Range("SurveyReturn") ' It's best to specify which sheet your source data is on. Presumably "ShSReturn" is the CodeName of your results sheet
Dim x As Long
For x = 7 To mytable.Cells(mytable.Cells.Count).Row ' Start at Row 7, and finish at the row number of the last cell in that Range
If mytable.Cells(x, **lastrow**).Value = "Ongoing" And mytable.Cells(x, **finalrow**).Value = "HP" Then
mytable.Cells(x, **resultrow**).Copy
ShPPT.Cells(cell, 17).PasteSpecial xlPasteValues
resultrow = resultrow + 1
End If
Next x
End Sub
Note that the above code will not work in its present form. What I have done is an approximation of what I think you're looking for: however you're going to have to do a bit of work, because the code in your question has some fundamental issues. For example, in your code you have lines like this:
mytable.Cells(cell, resultrow).Copy
However addressed cells within Ranges are in the format Range.Cells(Row, Column) - where Row and Column are numbers. However in your code resultrow as defined at the top is a Row, not a Column. You need to work out what exactly you want to copy, in terms of which row/column and re-write your code accordingly.
If you want to provide clarity, I'll be happy to edit my answer to accommodate what you want.

Collect interested data from tables in Excel

I have multi-tables in one sheet, how to collect my interested data from them.
for example, I just need the data of table1 column 3, and table2 column 2.
the size for both tables may be variate. I need collect the data into array for next processing.
Thanks.
You need to find a way to restrict the tables in VBA, i.e. know in which row they start and of how many rows they consist. Because the tables can appear anywhere in the sheet with variate dimensions, there is no straight-forward way of extracting their data.
What I would suggest is to loop from the top to the lastrow of the sheet and on every row check if the table started and then in an inner loop iterate through the table rows until the table ends (i.e. an empty row is encountered).
The code might look similar to this (not tested):
Dim LastRow as Long, i as Long, k as Long
Dim sht as Worksheet
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row 'Assuming the tables start in column A
For i=1 to LastRow
If (sht.Range("A" & i) <> "" Then 'table is encountered
k = i
Do While sht.Range("A" & k) <> ""
... 'Get data from specific column
k = k + 1
Loop
End if
i = k
Next i
Try this (necessary comments are in code):
Option Explicit
Sub CollectData()
Dim table1Address As String, table2Address As String
' here you specify cells that are at the start of a column
table1Address = "B2"
table2Address = "C7"
Dim firstCell As Range, lastCell As Range
Dim table1Data, table2Data As Variant
' determine last cell in column and read whole column at once to an array variable
Set firstCell = Range(table1Address)
Set lastCell = Range(table1Address).End(xlDown)
table1Data = Range(firstCell, lastCell).Value2
Set firstCell = Range(table2Address)
Set lastCell = Range(table2Address).End(xlDown)
table2Data = Range(firstCell, lastCell).Value2
End Sub

Copy a set of data multiple times based on criteria on another sheet

Excel 2010. I am trying to write a macro that could copy a set of data multiple times based on criteria on another sheet, but I've been stuck for a long time. I very much appreciate any help that could be offered to help me solve this problem.
Step 1: In the "Criteria" worksheet, there are three columns in which each row contains a specific combination of data. The first set of combination is "USD, Car".
Criteria worksheet
Step 2: Then the macro will move to the Output worksheet (please refer to the below link for screenshots), and then filter column A and B with the first set of criteria "USD" and "Car" in the "Criteria" worksheet.
Step 3: Afterwards, the macro will copy the filtered data into the last blank row. But the tricky part here is that, the filtered data has to be copied two times (as the "Number of set" column in the "Criteria" tab is 3 in this combination, and it doesn't have to copy the data three times since the filtered data would be treated as the first set of data)
Step4: After the filtered data have been copied, the "Set" column D will need to fill in the corresponding number of set that the rows are in. Therefore, in this 1st example, cell D2 and D8 will have "1" value, cell D14-15 will have "2" value, and cell D16-17 will have "3" value.
Step5: The macro will then move back to the "Criteria" worksheet and continue to based on the 2nd set of combination "USD, Plane" to filter the data in the "Output" worksheet. Again, it will copy the filtered data based on the "Number of set" in the "Criteria" worksheet. This process will continue until all the different combinations in the "Criteria" worksheet have been processed.
Output worksheet
Ok sorry for delay, here is a working version
you just have to add a sheet called "BF" because the autofilter count wasn't working properly so I had to use another sheet
Sub testfct()
Dim ShC As Worksheet
Set ShC = ThisWorkbook.Sheets("Criteria")
Dim EndRow As Integer
EndRow = ShC.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To EndRow
Get_Filtered ShC.Cells(i, 1), ShC.Cells(i, 2), ShC.Cells(i, 3)
Next i
End Sub
Sub Get_Filtered(ByVal FilterF1 As String, ByVal FilterF2 As String, ByVal NumberSetsDisered As Integer)
Dim NbSet As Integer
NbSet = 0
Dim ShF As Worksheet
Set ShF = ThisWorkbook.Sheets("Output")
Dim ColCr1 As Integer
Dim ColCr2 As Integer
Dim ColRef As Integer
ColCr1 = 1
ColCr2 = 2
ColRef = 4
If ShF.AutoFilterMode = True Then ShF.AutoFilterMode = False
Dim RgTotal As String
RgTotal = "$A$1:$" & ColLet(ShF.Cells(1, Columns.Count).End(xlToLeft).Column) & "$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row
ShF.Range(RgTotal).AutoFilter field:=ColCr1, Criteria1:=FilterF1
ShF.Range(RgTotal).AutoFilter field:=ColCr2, Criteria1:=FilterF2
'Erase Header value, fix? or correct at the end?
ShF.AutoFilter.Range.Columns(ColRef).Value = 1
Sheets("BF").Cells.ClearContents
ShF.AutoFilter.Range.Copy Destination:=Sheets("BF").Cells(1, 1)
Dim RgFilt As String
RgFilt = "$A$2:$B" & Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row '+ 1
Dim VR As Integer
'Here was the main issue, the value I got with autofilter was not correct and I couldn't figure out why....
'ShF.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
'Changed it to a buffer sheet to have correct value
VR = Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row - 1
Dim RgDest As String
ShF.AutoFilterMode = False
'Now we need to define Set's number and paste N times
For k = 1 To NumberSetsDisered - 1
'define number set
For j = 1 To VR
ShF.Cells(Rows.Count, 1).End(xlUp).Offset(j, 3) = k + 1
Next j
RgDest = "$A$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":$B$" & (ShF.Cells(Rows.Count, 1).End(xlUp).Row + VR)
Sheets("BF").Range(RgFilt).Copy Destination:=ShF.Range(RgDest)
Next k
ShF.Cells(1, 4) = "Set"
Sheets("BF").Cells.ClearContents
'ShF.AutoFilterMode = False
End Sub
And the function to get column letter using an integer input :
Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function

Resources