I'm trying to apply a macro when value from a cell change. I've this code in the Dashboard Sheet :
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("FilterChoice")) Is Nothing Then Call ApplyDashboardFilter
End Sub
The trigger works fine and the macro is executed right after, but don't know why I got an error on the Advanced filter function : "application-defined or object-defined error"
Option Explicit
Sub ApplyDashboardFilter()
Dim rng As Range
Dim filterName As String
Dim tableName As String
filterName = "Filter" & Replace(Sheets("Dashboard").Range("FilterChoice").Value, " ", "")
tableName = filterName + "[#All]"
Sheets("Dashboard").Activate
Sheets("Dashboard").Columns("A:AN").Cells.Clear
Sheets("Critical Flows").Range("ClosingFlows[#All]").AdvancedFilter Action:=xlFilterCopy _
, CriteriaRange:=Sheets(filterName).Range(tableName) _
, CopyToRange:=Sheets("Dashboard").Range("A1"), Unique:=False
Set rng = Range(Range("A1"), Range("A1").CurrentRegion)
ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = _
"Flows" & filterName
ActiveSheet.ListObjects("Flows" & filterName).TableStyle = "TableStyleMedium3"
If Sheets("Dashboard").Range("FilterChoice").Value = "Orchestrated" Then
Call ApplyFlormulaRunbookName
End If
End Sub
The macro works when triggered by a button on Dashboard sheet.
Am I missing something ?
Thanks in advance,
EDIT :
Well, something weird happened. I just re-opened the file after a break and it worked.
I suspect something happened with the ActiveSheet and / or a conflict with another workbook since I'm playing with 2 other workbooks and 10 sheets overall.
Is it possible ?
I've added as an answer as the comments won't allow me to format correctly. This code just references the sheets, rather than selecting them:
Sub ApplyDashboardFilter()
Dim rng As Range
Dim filterName As String
Dim tableName As String
Dim wrkShtDash As Worksheet
Dim wrkShtFlows As Worksheet
Set wrkShtDash = ThisWorkbook.Worksheets("Dashboard")
Set wrkShtFlows = ThisWorkbook.Worksheets("Critical Flows")
filterName = "Filter" & Replace(wrkShtDash.Range("FilterChoice").Value, " ", "")
tableName = filterName + "[#All]"
wrkShtDash.Columns("A:AN").Cells.Clear
wrkShtFlows.Range("ClosingFlows[#All]").AdvancedFilter Action:=xlFilterCopy _
, CriteriaRange:=ThisWorkbook.Worksheets(filterName).Range(tableName) _
, CopyToRange:=wrkShtDash.Range("A1"), Unique:=False
Set rng = wrkShtDash.Range(wrkShtDash.Range("A1"), wrkShtDash.Range("A1").CurrentRegion)
wrkShtDash.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = _
"Flows" & filterName
wrkShtDash.ListObjects("Flows" & filterName).TableStyle = "TableStyleMedium3"
If wrkShtDash.Range("FilterChoice").Value = "Orchestrated" Then
Call ApplyFlormulaRunbookName 'Spelt correctly?
End If
End Sub
Note: I haven't tested the code, it's just showing that you don't have to activate the sheet before working on it and is explicit about which file or sheet it's working with - ThisWorkbook means the file that the VBA code is in.
Related
I have an Excel with two sheets named "Complaints" and "Add Row".
I am using the Add Row sheet to add a row (after the last row with values) to a table named ComplaintsTable in Complaints sheet and I am using a macro paired with a command button to do this.
My code looks like this:
Private Sub CommandButton1_Click()
Dim LastRow As Long, ws As Worksheet, ws1 As Worksheet, newRow As ListRow
Set ws = Sheets("Complaints")
Set ws1 = Sheets("Add Row")
Set tbl = ws.ListObjects("ComplaintsTable")
Set newRow = tbl.ListRows.Add
With newRow
.Range(2) = ws1.Range("C1").Value 'Complaint Yes/No
.Range(12) = ws1.Range("C6").Value 'PCE Yes/No
End With
newRow.Range(4) = ws1.Range("C4").Value 'Subject
newRow.Range(21) = ws1.Range("C5").Value 'Entered Date
'To add Hyperlink
If (ws1.Range("C1").Value = "Yes") Then
ws.Hyperlinks.Add Anchor:=tbl.newRow.Range(3), _
Address:=ws1.Range("F3").Value, _
ScreenTip:="Open Complaint in EtQ", _
TextToDisplay:=Worksheets("Add Row").Range("F2").Value
End If
If (ws1.Range("C6").Value = "Yes") Then
'To add hyperlink and PCE Number
ws.Hyperlinks.Add Anchor:=tbl.newRow.Range(13), _
Address:=ws1.Range("F8").Value, _
ScreenTip:="Open PCE in EtQ", _
TextToDisplay:=ws1.Range("F7").Value
End If
End Sub
Somehow when I clicked the command button to add values it doesn't add anything! Where am I going wrong?
Here is your refactored, cleaned up code with screenshots. As mentioned by both #Ibo and myself, The problem most likely lies in the fact that you've declared and set newRow as a range but then used it as a property of your table which is impossible.
Option Explicit
Private Sub CommandButton1_Click()
Dim wsComplaints As Worksheet, wsAddRow As Worksheet
Dim tblComplaints As ListObject
Dim lngRows As Long
With ThisWorkbook
Set wsComplaints = .Worksheets("Complaints")
Set wsAddRow = .Worksheets("Add Row")
End With
Set tblComplaints = wsComplaints.ListObjects("ComplaintsTable")
tblComplaints.ListRows.Add
lngRows = tblComplaints.ListRows.Count
With tblComplaints
.DataBodyRange(lngRows, 2) = wsAddRow.Cells(1, 3)
.DataBodyRange(lngRows, 4) = wsAddRow.Cells(4, 3)
.DataBodyRange(lngRows, 12) = wsAddRow.Cells(6, 3)
.DataBodyRange(lngRows, 21) = wsAddRow.Cells(5, 3)
End With
If wsAddRow.Cells(1, 3) = "Yes" Then
tblComplaints.DataBodyRange(lngRows, 3).Hyperlinks.Add _
Anchor:=tblComplaints.DataBodyRange(lngRows, 3), _
Address:=CStr(wsAddRow.Cells(3, 6)), _
ScreenTip:="Open complaint in EtQ", _
TextToDisplay:=CStr(wsAddRow.Cells(2, 6))
End If
If wsAddRow.Cells(6, 3) = "Yes" Then
tblComplaints.DataBodyRange.Hyperlinks.Add _
Anchor:=tblComplaints.DataBodyRange(lngRows, 13), _
Address:=CStr(wsAddRow.Cells(8, 6)), _
ScreenTip:="Open PCE in EtQ", _
TextToDisplay:=CStr(wsAddRow.Cells(7, 6))
End If
End Sub
Screenshots of the solution.
If you click the button and nothing, not even an error of any sort, happens there may be several issues.
To start of with, as mentioned by #Carol, the newRow is not supposed to be qualified by tbl as newRow is not a property or method of tbl
Possibility 1:
You've added a Form Control button to your sheet which you are unable to assign a Private Sub CommandButton1_Click() because, well, it is private and can only be used within the code module it is placed in, it cannot be referenced outside of it.
Possibility 2:
You've added an ActiveX CommandButton, wrote the Private Sub CommandButton1_Click() but then changed the name of the button. In that case, change the CommandButton1 to whatever you've named your button.
Possibility 3:
You've encountered an error, hit debug and the code is paused. As long as the code is paused, no new event will fire and thus your button will appear to do nothing. This is recognized by a line of your code highlighted in yellow. You need to fix the line which caused the error and resume your code by hitting F5 or hitting the stop icon usually located somewhere near the top of your VBA window.
Your text to display must be a zero-length string and that is it is failing to create the hyperlink.
define the text to display like this before to make sure this line is the problem:
myStr=Worksheets("Add Row").Range("F2").Value
Try to define variables and range objects before adding the hyperlink, instead of using the .value etc put them in a string variable and make sure all of them have a valid value. If you try this, it should work, otherwise follow the above instruction and you will find where the problem is:
Replace this block and if it worked, change the other block in the same way:
If (ws1.Range("C1").Value = "Yes") Then
ws.Hyperlinks.Add Anchor:=tbl.newRow.Range(3), _
Address:=ws1.Range("F3").Value, _
ScreenTip:="Open Complaint in EtQ", _
TextToDisplay:=IIf(mystr <> "", mystr, "Click Here")
End If
I have changed the code as follows and it is working perfectly fine without any errors.
Private Sub AddRow_Click()
Dim LastRow As Long, ws As Worksheet, ws1 As Worksheet
Dim newRow As ListRow ', tbl As ListObjects
Dim cmpNo As String, pceNo As String
Set ws = Sheets("Complaints")
Set ws1 = Sheets("AddRow")
Set tbl = ws.ListObjects("ComplaintsTable")
Set newRow = tbl.ListRows.Add
With newRow
.Range(1) = ws1.Range("C1").Value 'Complaint Yes/No
.Range(11) = ws1.Range("C6").Value 'PCE Yes/No
.Range(3) = ws1.Range("C4").Value 'Subject
.Range(20) = ws1.Range("C5").Value 'Entered Date
End With
'To add Hyperlink
If (ws1.Range("C1").Value = "Yes") Then
Call ActiveSheet.Hyperlinks.Add(newRow.Range(2), ws1.Range("F3").Value, "", "Open in EtQ", ws1.Range("F2").Value)
End If
If (ws1.Range("C6").Value = "Yes") Then
Call ActiveSheet.Hyperlinks.Add(newRow.Range(12), ws1.Range("F8").Value, "", "Open in EtQ", ws1.Range("F7").Value)
'To add hyperlink and PCE Number
End If
End Sub
The problem with the code is that "newRow.Range" does not work with the " hyperlinks.add". I fugered out this a few days ago but I didn't get a chance to post this.
I appreciate all your help!
I have an activeX dropdown form on my spreadsheet which executes code on _Change. My code modifies the dropdowns list source (adding or deleting items). Whenever this happens, the _Change is called again.
I have various workarounds, all of which were some version of changing the list source, but with no success. The reason none of this has worked is because clearing or altering the .ListFillRange actually triggers the _Change event again.
How do I prevent the _Changeevent from getting called if I want to add or delete items in the .ListFillRange
UPDATE w EnableEvents set to false:
Public Sub SetRangeForDropdown()
On Error Resume Next
Application.EnableEvents = False
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
Application.EnableEvents = True
End Sub
Apperantly EnableEvents does not work for ActiveX controls.
Thank you Microsoft for making life just a little bit more complicated!
Just found this: "Application.EnableEvents=False/True ONLY applies to Sheet and Workbook Events, not ActiveX Control Events" from here enter link description here
You can disable the events in the SetRangeForDropdown and then enable them back.
So, write the following at the start:
Application.EnableEvents = False
And the following at the end:
Application.EnableEvents = true
it's always a good habit to make (nearly) sure that events handling is always brought back, like follows:
Public Sub SetRangeForDropdown()
'...your code
On Error GoTo ExitSub
Application.EnableEvents = False
wsMA.cmbEmployeeSelection.ListFillRange = rng2
'Update employee list named formula
ActiveWorkbook.Names.Add name:="nfEmployeeList", RefersTo:=rng2
ExitSub:
Application.EnableEvents = True
End Sub
Furthermore, avoid On Error Resume Next unless you really need it
I have solved the problem by adding a global variable that prevents the _Change event from firing. Here is that code:
Private Sub cmbEmployeeSelection_Change()
If bNOTRUN = False Then 'Check if ActiveX event should fire or not
modEmployeeDB.SaveEmployeeData 'Save currently selected employee data
modEmployeeDB.DBSoll_To_WorkerInfo 'Get called employee data
End If
End Sub
And this is the module as modified... note the simple Boolean variable that I added:
Public Sub SetRangeForDropdown()
On Error GoTo SetRangeForDropdown_Error
bNOTRUN = True 'Global Variable that when True prevents Active X from firing
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
bNOTRUN = False
On Error GoTo 0
Exit Sub
SetRangeForDropdown_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SetRangeForDropdown of Sub modEmployeeDB"
bNOTRUN = False
End Sub
I am trying to use some Parsing i was able to tweak a little. If I use it in straight VBA in excel, it works fine. However, when I use the same code as a module in VB.NET I get the error in the title on the line of code
ws.Range(vTitles).AutoFilter()
(duh!) I am not sure what is going wrong in the conversion, since I am not a hardcore VB.Net programmer, so I am doing a lot of googling, but not finding much that works. Any ideas on how this could be fixed or do I have to abandon the idea of using this snippet in VB.Net?
Here is the code I am using:
'turned strict off or autofilter per http://www.pcreview.co.uk/threads/autofilter-method-of-range-class-failed.3994483/
Option Strict Off
Imports xl = Microsoft.Office.Interop.Excel
Module ParseItems
Public Sub ParseItems(ByRef fileName As String)
'Jerry Beaucaire (4/22/2010)
'Based on selected column, data is filtered to individual workbooks are named for the value plus today's date
Dim wb As xl.Workbook
Dim xlApp As xl.Application
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As xl.Worksheet, MyArr As Object, vTitles As String, SvPath As String
'Set new application and make wb visible
xlApp = New xl.Application
xlApp.Visible = True
'open workbook
wb = xlApp.Workbooks.Open(fileName)
'Sheet with data in it
ws = wb.Sheets("Original Data")
'Path to save files into, remember the final "\"
SvPath = "G:\MC VBA test\"
'Range where titles are across top of data, as string, data MUST have titles in this row, edit to suit your titles locale
vTitles = "A1:L1"
'Choose column to evaluate from, column A = 1, B = 2, etc.
vCol = xlApp.InputBox("What column to split data by? " & vbLf & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
If vCol = 0 Then Exit Sub
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xl.XlDirection.xlUp).Row
'Speed up macro execution
'Application.ScreenUpdating = False
'Get a temporary list of unique values from key column
ws.Columns(vCol).AdvancedFilter(Action:=xl.XlFilterAction.xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True)
'Sort the temporary list
ws.Columns("EE:EE").Sort(Key1:=ws.Range("EE2"), Order1:=xl.XlSortOrder.xlAscending, Header:=xl.XlYesNoGuess.xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xl.Constants.xlTopToBottom, DataOption1:=xl.XlSortDataOption.xlSortNormal)
'Put list into an array for looping (values cannot be the result of formulas, must be constants)
MyArr = xlApp.WorksheetFunction.Transpose(ws.Range("EE2:EE" & ws.Rows.Count).SpecialCells(xl.XlCellType.xlCellTypeConstants))
'clear temporary worksheet list
ws.Range("EE:EE").Clear()
'Turn on the autofilter, one column only is all that is needed
ws.Range(vTitles).AutoFilter()
'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter(Field:=vCol, Criteria1:=MyArr(Itm))
ws.Range("A1:A" & LR).EntireRow.Copy()
xlApp.Workbooks.Add()
ws.Range("A1").PasteSpecial(xl.XlPasteType.xlPasteAll)
ws.Cells.Columns.AutoFit()
MyCount = MyCount + ws.Range("A" & ws.Rows.Count).End(xl.XlDirection.xlUp).Row - 1
xlApp.ActiveWorkbook.SaveAs(SvPath & MyArr(Itm), xl.XlFileFormat.xlWorkbookNormal)
'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51 'use for Excel 2007+
xlApp.ActiveWorkbook.Close(False)
ws.Range(vTitles).AutoFilter(Field:=vCol)
Next Itm
'Cleanup
ws.AutoFilterMode = False
MsgBox("Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!")
xlApp.Application.ScreenUpdating = True
End Sub
End Module
Looks like you need to specify at least one optional parameter. Try this:
ws.Range(vTitles).AutoFilter(Field:=1)
I realize this was closed years ago, but I recently ran into this problem and wanted to add to the solution.
This seems to only work when specifically using the first optional Field parameter. I attempted this fix using the optional VisibleDropDown parameter and still got this error.
ws.Range["A1"].AutoFilter(VisibleDropDown: true); Gives error
ws.Range["A1"].AutoFilter(Field: 1); No error
Everytime I execute my Macro (below) to search for a string that is entered into my search box, I get a Runtime error '1004'. AutoFilter method of Range class failed. I've tried looking for an answer to this problem on here for a while but nothing seems to provide me with a solution.
When I hit 'Debug' it highlights the below section of the code.
DataRange.AutoFilter _
Field:=myField, _
Criteria1:=SearchString, _
Operator:=xlAnd
I realise that this isn't much info but any help would be extremely appreciated.
P.S. I'm a complete novice with VBA and copied the code off a website that did a step by step guide to creating a search filter in Excel.
Sub SearchBox()
Dim myButton As OptionButton
Dim SearchString As String
Dim ButtonName As String
Dim sht As Worksheet
Dim myField As Long
Dim DataRange As Range
Dim mySearch As Variant
'Load Sheet into A Variable
Set sht = ActiveSheet
'Unfilter Data (if necessary)
On Error Resume Next
sht.ShowAllData
On Error GoTo 0
'Filtered Data Range (include column heading cells)
Set DataRange = sht.Range("A5:Z40000") 'Cell Range
'Set DataRange = sht.ListObjects("Table1").Range 'Table
'Retrieve User's Search Input
mySearch = sht.Shapes("UserSearch").TextFrame.Characters.Text 'Control Form
'mySearch = sht.OLEObjects("UserSearch").Object.Text 'ActiveX Control
'mySearch = sht.Range("A1").Value 'Cell Input
'Determine if user is searching for number or text
If IsNumeric(mySearch) = True Then
SearchString = "=" & mySearch
Else
SearchString = "=*" & mySearch & "*"
End If
'Loop Through Option Buttons
For Each myButton In sht.OptionButtons
If myButton.Value = 1 Then
ButtonName = myButton.Text
Exit For
End If
Next myButton
'Determine Filter Field
On Error GoTo HeadingNotFound
myField = Application.WorksheetFunction.Match(ButtonName, DataRange.Rows(1), 0)
On Error GoTo 0
'Filter Data
DataRange.AutoFilter _
Field:=myField, _
Criteria1:=SearchString, _
Operator:=xlAnd
'Clear Search Field
sht.Shapes("UserSearch").TextFrame.Characters.Text = "" 'Control Form
'sht.OLEObjects("UserSearch").Object.Text = "" 'ActiveX Control
'sht.Range("A1").Value = "" 'Cell Input
Exit Sub
'ERROR HANDLERS
HeadingNotFound:
MsgBox "The column heading [" & ButtonName & "] was not found in cells " & DataRange.Rows(1).Address & ". " & _
vbNewLine & "Please check for possible typos.", vbCritical, "Header Name Not Found!"
End Sub
check the value of myField, it must be between 1 and 26 because your range is A -> Z.
I've a macro which runs when user enters data in first cell. However, when I enter the data in first cell the macro executes the sql query and runs in the loop (104 times) and puts the column headers of the sql select statement on the spreadsheet.
Here is my macro:
Sub JobTaskHistory(ByVal Target As Range)
Dim sqlstring As String
Dim connstring As String
Dim Strcode As String
Dim rangeTest As Range
Set rangeTest = Range("A1")
'Strcode = Trim(InputBox("Please enter a Job Number", "Job Task history"))
Strcode = Target.Cells(1, 1).Value
sqlstring = "select distinct m.JobNumber , cast(m.ExpectedDate as DATE) 'Ship Date' , m.QuantityOrdered 'Quantity' & _
" from ArchiveJobHeader m left join AuxiliaryInfoFile af (nolock) on af.jobnumber=m.jobnumber left join JobExtra j on j.JobNumber = m.JobNumber " & _
" where m.JobNumber = '" & Trim(Strcode) & "'" & _
" order by 'Resulttime'"
connstring = "ODBC;DSN=Test;UID=Test;PWD=Test123"
Dim thisQT As QueryTable
Dim lastRow As Long, nextRow As Long
lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
nextRow = lastRow + 1
'Set thisQT = ActiveSheet.QueryTables.Add(Connection:=connstring, Destination:=Range("a1", "a1000"))
Set thisQT = ActiveSheet.QueryTables.Add( _
Connection:=connstring, _
Destination:=Range("A" & nextRow))
thisQT.BackgroundQuery = False
thisQT.Sql = sqlstring
thisQT.Refresh
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Call JobTaskHistory(Target)
End Sub
You can solve this by placing a Public variable in the module that contains the macro. If you don't have your macro in a module, you will need to put it in one, because this won't work from the Sheet code.
What Happens:
A value changes on the sheet.
The worksheet change event calls the macro.
The macro sets the public variable to TRUE.
Things change, triggering the change event again.
The change event tests for inProgress and if it IS TRUE, skips calling the macro.
The macro completes, and sets inProgress to False again.
In your module:
Public inProgress As Boolean
Sub JobTaskHistory(ByVal Target As Range)
inProgress = True
'YOUR CODE AS WRITTEN
inProgress = False
End Sub
In the worksheet code:
Private Sub Worksheet_Change(ByVal Target As Range)
If inProgress = False Then
Call JobTaskHistory(Target)
End If
End Sub
note:
Any time you have a change event, look to see what the scope is (ie, "worksheet_change"), because when you run anything as a result of it, if it causes the event to trigger again, you will have circular looping.
If you get caught in a loop you can't exit, try using 'Ctrl+PauseBreak'