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
Related
The script works fine if i put: ThisWorkbook but with ActiveWorkbook doesn't work.
Error 1004 say: "Unable to get the Match property of the Worksheet function class"
Dim dat As Date
calea_livrat = "my link" & ".xlsx"
Workbooks.Open calea_livrat
With ActiveWorkbook
dat = zi & "-" & luna & "-" & an
data_gen = CDbl(dat)
nr_linie = Application.WorksheetFunction.Match(data_gen, ActiveWorkbook.Worksheets("PE_Centralizare").Range("A:A"), 0)
MsgBox nr_linie
End With
Something is wrong here: Application.WorksheetFunction.Match(data_gen, ActiveWorkbook.Worksheets("PE_Centralizare").Range("A:A"), 0) but i can't figure out what.
This is not the answer, just how to use Match function in your case properly:
Dim nr_linie As Variant
With ActiveWorkbook
dat = zi & "-" & luna & "-" & an
data_gen = CDbl(dat)
' in case Match was able to find data_gen in Column A
If Not IsError(Application.Match(data_gen, .Worksheets("PE_Centralizare").Range("A:A"), 0)) Then
nr_linie = Application.Match(data_gen, .Worksheets("PE_Centralizare").Range("A:A"), 0)
MsgBox "Row number " & data_gen & " value was found in row " & nr_linie
Else ' <-- Macth failed, unable to find find data_gen in Column A
MsgBox data_gen & " value not found in Range !"
End If
End With
I want to test whether certain sheets in the current workbook exist in another closed workbook and return a message saying which sheet/s are causing errors.
I prefer not to open/close the workbook so I'm trying to change the formula in a random cell to link to the workbook of filepath (fp) to test whether the sheet exists.
I've tested this with a dummy sheet that I know doesn't exist in the other workbook and it works but when I have more than one sheet that causes errors I get an "Application-defined or object-defined error". On the second iteration I believe the way the error handling is written causes the crash but I don't exactly understand how that works.
The code I've got is:
Sub SheetTest(ByVal fp As String)
Dim i, errcount As Integer
Dim errshts As String
For i = 2 To Sheets.Count
On Error GoTo NoSheet
Sheets(1).Range("A50").Formula = "='" & fp & Sheets(i).Name & "'!A1"
GoTo NoError
NoSheet:
errshts = errshts & "'" & Sheets(i).Name & "', "
errcount = errcount + 1
NoError:
Next i
Sheets(1).Range("A50").ClearContents
If Not errshts = "" Then
If errcount = 1 Then
MsgBox "Sheet " & Left(errshts, Len(errshts) - 2) & " does not exist in the Output file. Please check the sheet name or select another Output file."
Else
MsgBox "Sheets " & Left(errshts, Len(errshts) - 2) & " do not exist in the Output file. Please check each sheet's name or select another Output file."
End If
End
End If
End Sub
Hopefully you guys can help me out here, thanks!
Here's a slightly different approach:
Sub Tester()
Dim s As Worksheet
For Each s In ThisWorkbook.Worksheets
Debug.Print s.Name, HasSheet("C:\Users\blah\Desktop\", "temp.xlsm", s.Name)
Next s
End Sub
Function HasSheet(fPath As String, fName As String, sheetName As String)
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
End Function
Just an update for Tim's Function for error Handling:
VBA:
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err.Number <> 0 Then
HasSheet = False
End If
On Error GoTo 0
End Function
Sub Tester()
MsgBox (Not IsError(Application.ExecuteExcel4Macro("'C:\temp[temp.xlsm]Sheetxyz'!R1C1")))
End Sub
UDF "NAV()" is designed to find the correct report on a network drive based on the first argument (always a date), then loop through all worksheets to find a piece of data with the same row as second argument and same column as third argument (second and third can be text or numbers).
Works reliably in the immediate window. Always returns #VALUE! when used on worksheet, e.g. =NAV(D7,D8,D9) or =NAV(2/19/2016,"Net Asset Value","221-I").
In general it looks like one could get this behaviour if trying to alter other cells in a UDF, but my functions don't do that. Also, I believe all range references specify which workbook and worksheet, so I don't think that is the problem either. I'm not sure where to look next.
Function also attempts to email me a report through Outlook when it fails to find what the user is looking for. I don't know if that is relevant.
Again, what is perplexing is that this code seems to work fine in the immediate window, but only gives #VALUE! when used on a worksheet.
Where else can I look in my code below to determine what would cause NAV() to function correctly in the immediate window, but always yield #VALUE! when used on a worksheet?
Option Explicit
Function NAV(ByVal NAVDate As Date, ByVal matchRow As Variant, ByVal matchColumn As Variant) As Variant
'Application.ScreenUpdating = False
Application.Volatile True
NAV = FindItemOnWorksheet(NAVDate, matchRow, matchColumn)
'Application.ScreenUpdating = True
End Function
Function FindItemOnWorksheet(ByVal NAVDate As Date, ByVal ItemSpecies As Variant, ByVal ItemGenus As Variant) As Variant
' Finds Item by opening NAV workbook with correct date, activating correct worksheet, and searching for correct row and column
Dim startingRange As Range
Dim ws As Worksheet
Dim wb As Workbook
Dim theDate As Date
Dim theItemSpecies As String
Dim theItemGenus As String
theDate = NAVDate
theItemSpecies = ItemSpecies
theItemGenus = ItemGenus
Set wb = GetWB(NAVDate)
'Loop through ws
Dim WS_Count As Integer
Dim i As Integer
WS_Count = wb.Worksheets.Count
For i = 1 To WS_Count
Set ws = wb.Worksheets(i)
Set startingRange = ws.Range("A1:Z100")
Dim theRow As Range
Dim theColumn As Range
Set theRow = startingRange.Cells.Find(theItemSpecies, SearchDirection:=xlPrevious, lookat:=xlWhole)
If Not (theRow Is Nothing) Then
Set theColumn = startingRange.Cells.Find(theItemGenus, SearchDirection:=xlPrevious, lookat:=xlWhole)
If Not (theColumn Is Nothing) Then
FindItemOnWorksheet = ws.Cells(theRow.Row, theColumn.Column).Value
wb.Close
Exit Function
End If
End If
Next i
'Loop if no hit on either row or column Find()
'following executes only if no match found
MsgBox "No Match Found. Make sure you are entering arguments--" & vbNewLine & _
" The Date of NAV, " & vbNewLine & _
" the entry found in the right row of NAV workbooks (e.g. 'Net Asset Value'), " & vbNewLine & _
" the right column (e.g. 'Fund')." & vbNewLine & _
" This function will only find exact matches." & vbNewLine & vbNewLine & _
"Now emailing developer to ask for a fix."
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "User attempted" & _
"=FindItemOnWorksheet( " & theDate & ", " & theItemSpecies & ", " & theItemGenus & " )" & vbNewLine & _
"theDate type " & TypeName(theDate) & vbNewLine & _
"theItemSpecies type " & TypeName(theItemSpecies) & vbNewLine & _
"theItemGenus type " & TypeName(theItemGenus)
On Error Resume Next
With OutMail
.To = <Address Removed>
.CC = ""
.BCC = ""
.Subject = "FindItemOnWorksheet Error"
.Body = strbody
'.Attachments.Add ("C:\file.xlsx")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
FindItemOnWorksheet = "Error"
'wb.Close
Exit Function
End Function
Function GetWB(ByVal NAVDate As Date) As Workbook
'Open requested workbook, return to parent procedure
Dim wbPath As String
Dim wbYear As String
Dim wbMonth As String
Dim wbWeek As String
Dim wbFile As String
Dim wbString As String
Dim wb As Workbook
Dim BackADay As Boolean
Dim OriginalNAVDateRequested As Date
OriginalNAVDateRequested = NAVDate
BackADay = True
'Loop through possible file tree structures and dates to find the closest NAV in the past to the date requested.
Do While BackADay = True
'Don't go back to a previous week if cannot find current NAV
If OriginalNAVDateRequested - NAVDate > 4 Then
BackADay = False
End If
wbPath = <Network Path Removed>
wbYear = CStr(Year(NAVDate)) & "\"
wbMonth = MonthName(Month(NAVDate)) & " " & wbYear
wbWeek = DateFormat(NAVDate) & "\"
wbFile = Dir(wbPath & wbYear & wbMonth & wbWeek & "*Valuation Package*.xlsx")
'Pricings with distributions have differing tree structure
If wbFile = "" Then
wbWeek = wbWeek & "POST Distribution " & wbWeek
wbFile = Dir(wbPath & wbYear & wbMonth & wbWeek & "*Valuation Package*.xlsx")
If wbFile = "" Then
NAVDate = NAVDate - 1
Else: BackADay = False
End If
Else: BackADay = False
End If
Loop
wbString = wbPath & wbYear & wbMonth & wbWeek & wbFile
Set wb = Workbooks.Open(wbString, UpdateLinks:=False, ReadOnly:=True)
Set GetWB = wb
End Function
Function DateFormat(ByVal X As Date) As String
'Appends leading zeroes if needed to achieve form "00" for any two digit integer, and converts to string
Dim MM As String
Dim DD As String
Dim YYYY As String
If Month(X) < 10 Then
MM = "0" & CStr(Month(X))
Else
MM = CStr(Month(X))
End If
If Day(X) < 10 Then
DD = "0" & CStr(Day(X))
Else
DD = CStr(Day(X))
End If
YYYY = CStr(Year(X))
DateFormat = MM & "." & DD & "." & YYYY
End Function
You can Open Workbooks within a Worksheet_Change Event.
For demonstration, if a change in Sheet1!A2, Excel will try open the workbook name with that cell value, then Output the status to Sheet1!A4.
Put below in a Module:
Option Explicit
Function TryOpenWB(ByVal oItem As Variant) As Variant
Dim sOut As String
Dim oWB As Workbook
On Error Resume Next
Set oWB = Workbooks.Open(CStr(oItem))
If oWB Is Nothing Then
sOut = "Cannot open """ & CStr(oItem) & """"
Else
sOut = "Opened """ & CStr(oItem) & """ successfully."
'oWB.Close
End If
TryOpenWB = sOut
End Function
Then below in Worksheet Module (I used Sheet1 for demonstration):
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Range("A2").Address Then
Application.EnableEvents = False
Range("A4").Value = TryOpenWB(Target)
Application.EnableEvents = True
End If
End Sub
So this idea is to open the Workbook only if some cell address is matched.
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.
Interesting problem here. This line of code works through multiple iterations until it reaches a point where it throws an Run-time error 91 at me: "Object Variable or With block variable not set". This is occurring in a function designed to find a deal number. The entire program is an end of day email generation program that sends attachments to various different counter-parties. The error occurs on the ** line. For additional color, temp deal is not empty when execution is attempted. There doesn't appear to be any extraneous trailing or leading spaces either. Thanks in advance!
Function getPDFs(cFirm As Variant, iFirm As Variant, row_counter As Variant, reportsByFirm As Worksheet, trMaster As Worksheet, trSeparate As Variant, trName As Variant, reportDate As Variant) As String
dealCol = 1
Dim locationArray() As String
Dim DealArray() As String
cDes = "_vs._NY"
iDes = "_vs._IC"
filePath = "X:\Office\Confirm Drop File\"
dealNum = reportsByFirm.Cells(row_counter, dealCol)
FileType = ".pdf"
If InStr(1, dealNum, "-") > 0 Then
DealArray() = Split(dealNum, "-")
tempDeal = DealArray(LBound(DealArray))
Else
tempDeal = dealNum
End If
'Finds deal location in spread sheet for further detail to obtain file path
**trLocation = trMaster.Columns(2).Find(What:=tempDeal).Address
locationArray() = Split(trLocation, "$")
trRow = locationArray(UBound(locationArray))
'Formats client names for 20 characters and removes punctuation (".") in order to stay within convention of file naming
cFirmFormatted = Trim(Left(cFirm, 20))
iFirmFormatted = Trim(Left(iFirm, 20))
'Finds clearing method
clMethod = trMaster.Cells(trRow, 6).Value
Select Case clmethod
Case "Clport"
'Prevents naming convention issues with punctuations in the name
If InStr(1, cFirmFormatted, ".") > 0 Then
cFirmFormatted = Replace(cFirmFormatted, ".", "")
End If
getPDFs = filePath & cFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & cFirmFormatted & cDes & FileType
Case "ICE"
If InStr(1, iFirmFormatted, ".") > 0 Then
iFirmFormatted = Replace(iFirmFormatted, ".", "")
End If
getPDFs = filePath & iFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & iFirmFormatted & iDes & FileType
End Select
End Function
Your code assumes that trLocation is always found, if it isn't found then you will receive an error because you don't have a range to return the .Address property for.
Try testing the result first:
Dim testLocation As Excel.Range
Set testLocation = trMaster.Columns(2).Find(tempDeal)
If Not testLocation Is Nothing Then
trLocation = testLocation.Address
'// Rest of code here...
Else
MsgBox "Cannot find """ & tempDeal & """!"
Exit Function
End If