Error when running Excel Add-In Macro from Excel Ribbon - vba

I updated the code in an excel add-in I created that is saved on my company's shared drive. I've added some of the add-ins macros under a custom tab on the Excel ribbon. Before updating the code, I already had it set as an Active Application Add-In, so I figured I could just update the code and the buttons would work just like they were before. However, when I click one of the custom ribbon buttons I get the error "Cannot run the macro "macro file path". The macro may not be available in this workbook or all macros may be disabled".
I've googled for solutions already and most involve changing Trust Center Settings-->Macro Settings to Enable all macros and checking the Trust Access to the VBA project object model button, which I had done before updating the add-in code.
I've also opened up the VBE and see the add-in file in the Project Explorer window right next to the workbook I'm trying to run the add-in macro from. Does anyone know why this is happening? It was working fine until I updated the add-in code.
Here is the original add-in code:
Function BuildBudgetSQL(PageFilters As Range, Table As Range)
Application.Volatile
'PageFilters As String, Year As Date, x_axis As String, y_axis As String)
Dim cell As Range
'Starts SQL statement
BuildBudgetSQL = "SELECT * FROM " & "[" & Table.Offset(0, 2).Value & "]" & " WHERE "
'Adds WHERE and AND clauses to SQL statement
For Each cell In PageFilters
BuildBudgetSQL = BuildBudgetSQL & "[" & cell.Value & "] " & cell.Offset(0, 1) & " '" & cell.Offset(0, 2).Value & "'" & " " & cell.Offset(1, -1).Value & " "
Next
'Chops off trailing " AND" and add ";" on end of SQL statement
BuildBudgetSQL = Mid(BuildBudgetSQL, 1, Len(BuildBudgetSQL) - 2) & ";"
End Function
Sub GetBudgetTable()
Dim dbFilePath As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim cell As Range
Dim Year As String
Dim SQL As String
'For Each cell In Range("A1:A100")
'If InStr(1, cell.Name, "SQL", vbTextCompare) > 0 Then
Year = Sheets("Report").Range("Year").Value
SQL = Sheets("Report").Range("BudgetSQL").Value
dbFilePath = "H:\CORP\CFR-2011_to_Current\Budget\2015\Budget Variance\Budget Variance - Pivot\Test\More Tests\Administrative\Database\" & Year & " Budget.accdb"
Set db = Access.DBEngine.OpenDatabase(dbFilePath, False, True)
Set rs = db.OpenRecordset(SQL)
Sheets("Budget Table").Range("a2:y50000").ClearContents
Sheets("Budget Table").Range("A2").CopyFromRecordset rs
db.Close
Sheets("Report").PivotTables("BudgetDetail").RefreshTable
'End If
'Next
End Sub
And here's the new code:
Function BuildSQL(FieldNames As Range, Table As Range, PageFilters As Range)
Application.Volatile
Dim cell As Range
'Starts SQL statement
BuildSQL = "SELECT "
'Adds field names to SELECT clause of SQL statement
For Each cell In FieldNames
If cell.Value <> "" Then
BuildSQL = BuildSQL & "[" & Table.Offset(0, 2).Value & "]." & "[" & cell.Value & "]" & ", "
End If
Next
'Chops off trailing "," on end of SQL statement
BuildSQL = Mid(BuildSQL, 1, Len(BuildSQL) - 2)
'Adds FROM clause, table name, and WHERE clause
BuildSQL = BuildSQL & " FROM " & "[" & Table.Offset(0, 2).Value & "]" & " WHERE "
'Adds criteria to SQL statement's WHERE clause
For Each cell In PageFilters
If cell.Value <> "" Then
BuildSQL = BuildSQL & "[" & cell.Value & "] " & cell.Offset(0, 1) & " '" & cell.Offset(0, 2).Value & "'" & " " & cell.Offset(1, -1).Value & " "
End If
Next
'Chops off trailing " AND" and add ";" on end of SQL statement
BuildSQL = Mid(BuildSQL, 1, Len(BuildSQL) - 2) & ";"
End Function
Sub GetBudgetTable()
Dim dbFilePath As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim cell As Range
Dim Year As String
Dim SQL As String
Year = Sheets("Report").Range("Year").Value
SQL = Sheets("Report").Range("BudgetSQL").Value
'pulls budget
dbFilePath = "H:\CORP\CFR-2011_to_Current\Budget\2015\Budget Variance\Budget Variance - Pivot\Test\More Tests\Administrative\Database\" & Year & " Budget.accdb"
Set db = Access.DBEngine.OpenDatabase(dbFilePath, False, True)
Set rs = db.OpenRecordset(SQL)
Sheets("Budget Table").Range("A2:AJ80000").ClearContents
Sheets("Budget Table").Range("A2").CopyFromRecordset rs
db.Close
'pulls actuals
dbFilePath = "H:\CORP\CFR-2011_to_Current\Budget\2015\Budget Variance\Budget Variance - Pivot\Test\More Tests\Administrative\Database\" & Year & " Actuals - Summary.accdb"
Set db = Access.DBEngine.OpenDatabase(dbFilePath, False, True)
Set rs = db.OpenRecordset(SQL)
Sheets("Budget Table").Range("A2").End(xlDown).Offset(1, 0).CopyFromRecordset rs
db.Close
Sheets("Report").PivotTables("Pivot").RefreshTable
End Sub
Sub ActualDrilldown()
'http://stackoverflow.com/questions/34804259/vba-code-to-return-pivot-table-cells-row-column-and-page-fields-and-items/34830798?noredirect=1#comment57563829_34830798
Dim pvtCell As Excel.PivotCell
Dim pvtTable As Excel.PivotTable
Dim pvtField As Excel.PivotField
Dim pvtItem As Excel.PivotItem
Dim pvtParentItem As Excel.PivotField
Dim i As Long
Dim SQL As String
Dim dict As Scripting.Dictionary
Set dict = New Scripting.Dictionary
dict.Add "Jan", "Jan"
dict.Add "Feb", "Feb"
dict.Add "Mar", "Mar"
dict.Add "Apr", "Apr"
dict.Add "May", "May"
dict.Add "Jun", "Jun"
dict.Add "Jul", "Jul"
dict.Add "Aug", "Aug"
dict.Add "Sep", "Sep"
dict.Add "Oct", "Oct"
dict.Add "Nov", "Nov"
dict.Add "Dec", "Dec"
On Error Resume Next
Set pvtCell = ActiveCell.PivotCell
If Err.Number <> 0 Then
MsgBox "The cursor needs to be in a pivot table"
Exit Sub
End If
On Error GoTo 0
If pvtCell.PivotCellType <> xlPivotCellValue Then
MsgBox "The cursor needs to be in a Value field cell"
Exit Sub
End If
SQL = "SELECT * FROM [Actual Detail] WHERE "
'Checks if PivotField.SourceName contains a month. If not, exit sub; otherwise, adds Value Field Source to SQL statement
If dict.Exists(Left(pvtCell.PivotField.SourceName, 3)) = False Then
MsgBox "A month field must be in the column field of the active pivot cell before drilling.", vbOKOnly
Exit Sub
End If
SQL = SQL & "[" & Left(pvtCell.PivotField.SourceName, 3) & "]" & "IS NOT NULL AND "
'Adds rowfields and rowitems to SQL statement
For i = 1 To pvtCell.RowItems.Count
Set pvtParentItem = pvtCell.RowItems(i).Parent
SQL = SQL & "[" & pvtParentItem.Name & "]" & "=" & "'" & pvtCell.RowItems(i).Name & "'" & " AND "
Next i
'Adds columnfields and columnitems to SQL statement
For i = 1 To pvtCell.ColumnItems.Count
Set pvtParentItem = pvtCell.ColumnItems(i).Parent
SQL = SQL & "[" & pvtParentItem.Name & "]" & "=" & "'" & pvtCell.ColumnItems(i).Name & "'" & " AND "
Next i
'Chops off trailing "AND" on end of SQL statement
SQL = Mid(SQL, 1, Len(SQL) - 5) & ";"
Debug.Print SQL
End Sub
I know the code is long and isn't pretty, but if you want the full information, there it is.
I appreciate and thank you for your help!

I figured it out! There were two things I needed to do:
1) I added ActiveWorkbook to the subs code where applicable.
2) This was the tricky part - I realized I have to remove the sub from the Excel ribbon and then add it back. Apparently, when you update a sub in the add-in, the button on the Excel ribbon that runs that sub does not update. You have to remove the button from the Excel ribbon and add it back on.
After doing both of these steps, the add-in worked correctly.
I sure hope there is a way around having to manually remove and add the add-in sub back each time I make a change to the add-in. I'll google this and maybe open up a new question thread.

Related

MS Access - SQL Query for Max Date

I am creating a schedule calendar which has been working great, but I want to adjust the SQL so that it only shows when the next job has to be done. I was thinking the best way to achieve this would be via the MAX() function, however when i run the code Access doesn't seem to like it.
Public Sub LoadArray()
'This sub loads an array with the relevant variables from a query
Dim db As Database
Dim rs As Recordset
Dim rsFiltered As Recordset
Dim strQuery As String
Dim i As Integer
Dim Text23 As Integer
On Error GoTo ErrorHandler
Text23 = Forms.frmPreventativeMenu.Form.CompanyName.Value
strQuery = "SELECT tblWMYReports.Company, tblWMYReports.Machine, MAX(tblWMYReports.NextDate), tblWMYReports.WMY " _
& "FROM tblWMYReports " _
& "WHERE (((tblWMYReports.Company)= " & Text23 & " ));"
Set db = CurrentDb
Set rs = db.OpenRecordset(strQuery)
With rs
If Not rs.BOF And Not rs.EOF Then
'Ensures the recordset contains records
For i = 0 To UBound(MyArray)
'Will loop through the array and use dates to filter down the query
'It firsts checks that the second column has true for its visible property
If MyArray(i, 1) = True Then
.Filter = "[NextDate]=" & MyArray(i, 0)
'To filter you must open a secondary recordset and
'Use that as the basis for a query
'This makes sense as you are building a query on a query
Set rsFiltered = .OpenRecordset
If Not rsFiltered.BOF And Not rsFiltered.EOF Then
'If the recordset is not empty then you are able
'to extract the text from the values provided
Do While Not rsFiltered.EOF = True
MyArray(i, 2) = MyArray(i, 2) & vbNewLine & DLookup("MachineName", "tblMachine", "MachineID=" & rsFiltered!Machine)
MyArray(i, 2) = MyArray(i, 2) & " - " & DLookup("WMY", "tblWMY", "ID=" & rsFiltered!WMY)
rsFiltered.MoveNext
Loop
End If
End If
Next i
End If
.Close
End With
ExitSub:
Set db = Nothing
Set rs = Nothing
Exit Sub
ErrorHandler:
MsgBox "There has been an error. Please reload the form.", , "Error"
Resume ExitSub
End Sub
You are going to aggregate one column with an aggregate function like Sum(), Max(), Count() or similar, then every other column that isn't being aggregated must show up in the SQL's GROUP BY clause:
strQuery = "SELECT tblWMYReports.Company, tblWMYReports.Machine, MAX(tblWMYReports.NextDate), tblWMYReports.WMY " _
& "FROM tblWMYReports " _
& "WHERE (((tblWMYReports.Company)= " & Text23 & " )) " _
& "GROUP BY tblWMYReports.Company, tblWMYReports.Machine, tblWMYReports.WMY;"
I can't guarantee that is going to do what you want it to, since I'm not familiar with your data, code, or application, but it should get you through the error.
You must use a properly formatted string expression for the date value:
.Filter = "[NextDate] = #" & Format(MyArray(i, 0), "yyyy\/mm\/dd") & "#"

Save As to Variable File Paths

Trying to use an Excel-macro that will automatically save the workbook once certain cells are filled in. The macro will check when changes are made to specific cells, then use variable data to save the workbook through a folder system organized by year and quarter, while giving the Workbook a name based on the Current date and a cell number. The macro will also check to see if the network path (it being on a server) is connected, and if not, exit the sub. I am getting a compile error "Expected: end of statement" at
Set mTitle = Year(Now)," & . & ", Month(Now), " &.& ", Day(Now), " & - & ", ActiveWorkbooks.Sheets("Control").Cells(1, "C")
I want to save the workbook with the following format: Year.Month.Day - CellValue, but it looks like VBA doesn't like periods. How can I solve this? Full code below.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cYear As String
Dim Quarter As String
Dim fdObj As Object
Dim mTitle As String
Dim sCheck
Application.ScreenUpdating = False
Set cYear = Year(Now)
Set Quarter = (Month(Now) + 2) \ 3
Set fdObj = CreateObject("Scripting.FileSystemObject")
sCheck = "S:\Estimating Data\Estimates\test.txt"
Set mTitle = Year(Now)," & . & ", Month(Now), " &.& ", Day(Now), " &.& ", ActiveWorkbooks.Sheets("Control").Cells(1, "C")
If Intersect(Target, Range("C1:C5")) Is Nothing Then
Exit Sub
Else
If WorksheetFunction.CountA(Range("C1:C5")) = 0 Then
Exit Sub
Else
Shell ("Net View \\S:\ > " & vsFileName)
If FileLen(vsFileName) = 0 Then
Exit Sub
Else
If fdObj.FolderExists("S:\Estimating Data\Estimates\" & cYear & "\""Q" & Quarter & ".*xlsm") Then
ActiveWorkbook.SaveAs Filename:="S:\Estimating Data\Estimates\" & cYear & "\""Q" & Quarter & "\" & mTitle & ".*xlsm"
Else
fdObj.CreateFolder ("S:\Estimating Data\Estimates\" & cYear & "\""Q" & Quarter & ".*xlsm")
End If
End If
End If
End If
End Sub

How do i use the IF condition depending on the input contained in a column (not in a cell)?

I have an excel-workbook containing two worksheets, and I have written code to transfer data from sheet No.1 to sheet No.2.
What I need is to include a condition that checks if the column G does not contain a certain value. In that case I would like a MsgBox to display "Check..".
The interested range in the Sheet 1 is (A3:J50), so the condition would interest cells G3 to G50.
My current code is:
Sub kk()
Dim lastrow As Integer
lastrow = [b50].End(xlUp).Row
Range("b3:J" & lastrow).Copy Sheets("Daily Rec.").Range("b" & Sheets("Daily Rec.").[b1000].End(xlUp).Row + 1)
Range("b3:j" & lastrow).ClearContents
MsgBox ("Date Posted")
Sheets("Daily Rec.").Activate
MsgBox ("Check..")
End Sub
please advice
This should help get you started.
But like others have mentioned, we need more info to help.
Sub Okay()
Dim source As Range
Dim target As Range
Dim found As Range
Dim cell As Range
Set source = ThisWorkbook.Worksheets("Sheet 1").Range("A3:J50")
Set target = ThisWorkbook.Worksheets("Sheet 2").Range("G3:G50")
For Each cell In source.Cells
Set found = target.Find(cell.Value)
If found Is Nothing Then
MsgBox "Check.." & vbNewLine _
& "Cell [" & cell.Address(0, 0) & "] on sheet [" & cell.Parent.Name & "]" _
& vbNewLine _
& "was not found within " & vbNewLine _
& "cell range of [" & target.Address(0, 0) & "] on sheet [" & target.Parent.Name & "]"
End If
Next cell
End Sub

VBA Query based on multiple "multiple select list boxes" in Access when not selecting an item from one of the multiple select boxes

I have the following vba that creates a query in a test Access database. I have two multiple select list boxes. The issue is, i want to be able to select multiple items from "Me![State]" and none from "Me![Animal]" and be able to run the query. However, this is not possible as the query language is not set up to handle that. It makes me select something from "Me![Animal]".
How do i revise the vba below to allow me to query on both multiple selection list boxes if one of the multiple list boxes does not have anything selected or if both have selections in them?
Private Sub Command6_Click()
Dim Q As QueryDef, DB As Database
Dim Criteria As String
Dim ctl As Control
Dim Itm As Variant
Dim ctl2 As Control
Dim ctl3 As Control
' Build a list of the selections.
Set ctl = Me![Animal]
For Each Itm In ctl.ItemsSelected
If Len(Criteria) = 0 Then
Criteria = Chr(34) & ctl.ItemData(Itm) & Chr(34)
Else
Criteria = Criteria & "," & Chr(34) & ctl.ItemData(Itm) _
& Chr(34)
End If
Next Itm
If Len(Criteria) = 0 Then
Itm = MsgBox("You must select one or more items in the" & _
" list box!", 0, "No Selection Made")
Exit Sub
End If
Set ctl2 = Me![State]
For Each Itm In ctl2.ItemsSelected
If Len(Criteria2) = 0 Then
Criteria2 = Chr(34) & ctl2.ItemData(Itm) & Chr(34)
Else
Criteria2 = Criteria2 & "," & Chr(34) & ctl2.ItemData(Itm) _
& Chr(34)
End If
Next Itm
If Len(Criteria2) = 0 Then
Itm = MsgBox("You must select one or more items in the" & _
" list box!", 0, "No Selection Made")
Exit Sub
End If
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
Q.SQL = "Select * From [table1] Where [table1].[type] In (" & "'Animal'" & _
")" & " and [table1].[animal] in (" & Criteria & _
")" & " and [table1].[state] in (" & Criteria2 & _
")" & ";"
Q.Close
' Run the query.
DoCmd.OpenQuery "animalquery"
End Sub
EDIT - Fix comparison as per comment
You can do this with a simple check of your Criteria vaiables.
You already do the the length check - just use it later on when you build the dynamic SQL.
I added a strSQL variable to make it easier to track what's happening. And adjusted the error message to allow one or other criteria being empty
Private Sub Command6_Click()
Dim Q As QueryDef
Dim DB As Database
Dim Criteria As String
Dim ctl As Control
Dim Itm As Variant
Dim ctl2 As Control
Dim ctl3 As Control
' Use for dynamic SQL statement'
Dim strSQL As String
Set ctl = Me![Animal]
For Each Itm In ctl.ItemsSelected
If Len(Criteria) = 0 Then
Criteria = Chr(34) & ctl.ItemData(Itm) & Chr(34)
Else
Criteria = Criteria & "," & Chr(34) & ctl.ItemData(Itm) & Chr(34)
End If
Next Itm
Set ctl2 = Me![State]
For Each Itm In ctl2.ItemsSelected
If Len(Criteria2) = 0 Then
Criteria2 = Chr(34) & ctl2.ItemData(Itm) & Chr(34)
Else
Criteria2 = Criteria2 & "," & Chr(34) & ctl2.ItemData(Itm) & Chr(34)
End If
Next Itm
If (Len(Criteria) = 0) And (Len(Criteria2) = 0) Then
Itm = MsgBox("You must select one or more items from one of the list boxes!", 0, "No Selection Made")
Exit Sub
End If
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
strSQL = "Select * From [table1] Where [table1].[type] In (" & "'Animal')"
If (Len(Criteria) <> 0) Then ' Append Animal Criteria
strSQL = strSQL & " AND [table1].[animal] IN (" & Criteria & ")"
End If
If (Len(Criteria2) <> 0) Then ' Append State Criteria
strSQL = strSQL & " AND [table1].[state] IN (" & Criteria2 & ")"
End If
Q.SQL = strSQL
Q.Close
' Run the query.
DoCmd.OpenQuery "animalquery"
End Sub

Excel Application Crash due to Macro

During launching my macro the Excel application is crashed. If I test the macro with an integer the program runs properly (partnumber = 123). If I check with a string the application is crashed. Thus, no error code is visible for me. I assume that there is a type mismatch (but I set Variant for partnumber)
Sub SbIsInCOPexport()
Dim lastRow As Long
Dim i As Long
Dim found As Boolean
Dim partnumber As Variant
i = 1
found = False
partnumber = ActiveCell.Value
Windows("COPexport.xlsx").Activate
lastRow = Sheets(1).Cells.SpecialCells(xlLastCell).Row
Do While i < lastRow + 1
If Cells(i, 6).Value = partnumber Then
found = True
Exit Do
End If
i = i + 1
Loop
If found = True Then
Cells(i, 6).Select
MsgBox ("Searched part number: " & Str(partnumber) & vbNewLine & "Found part number: " _
& ActiveCell.Value & vbNewLine & "Address: " & Cells(i, 6).Address & vbNewLine & vbNewLine & "Test Order: " & _
Cells(i, 2).Value)
Windows("COPexport.xlsx").Activate
Else
MsgBox "Part number is not found in the COP samples!"
Windows("COPexport.xlsx").Activate
End If
End Sub
What can be the root cause?
I don't see any obvious issues, but consider using the .Find method of range object, like so:
Sub SbIsInCOPexport()
Dim partnumber as Variant
Dim rng as Range
Windows("COPexport.xlsx").Activate
partnumber = ActiveCell.Value
Set rng = Columns(6).Find(partnumber) '## Search in column 6 for partnumber
If rng Is Nothing Then
MsgBox "Part number is not found in the COP samples!"
Windows("COPexport.xlsx").Activate
Else
With rng
MsgBox ("Searched part number: " & Str(partnumber) & vbNewLine & _
"Found part number: " & .Value & vbNewLine & _
"Address: " & .Address & vbNewLine & vbNewLine & _
"Test Order: " & .Offset(0,-4).Value) '## Get the value from column 2
End With
End If
End Sub