We help IT Professionals succeed at work.

Need a custom macro for Excel 2010

agbnielsen
agbnielsen asked
on
Hi All,

I need to program a macro into a Excel 2010 ribbon button for a few users.

Simply all I need to do is take the current file name that is open in Excel (spreadsheet.xlsm) and save it to C:\Daily Insight Reports.

Please see the attached image for the logic that I would like the button to follow.

Please feel free to ask for anything that may require clarification.

Cheers

1
Comment
Watch Question

CERTIFIED EXPERT
Most Valuable Expert 2012
Top Expert 2014

Commented:
Hi there,

This should work for testing as a template (xltm):
Sub SaveAsJPG()
    If InStr(ActiveWorkbook.Name, ".") > 0 Then
        strWorkbookName = ActiveWorkbook.Name
        strSaveFolder = "C:\Daily Insight Report Files\"
        If Right(strSaveFolder, 1) = "\" Then strSaveFolder = Left(strSaveFolder, Len(strSaveFolder) - 1)
        If Dir(strSaveFolder, vbDirectory) = "" Then MkDir strSaveFolder
        blnContinue = False
        If Dir(strSaveFolder & "\" & strWorkbookName) <> "" Then
            intResponse = MsgBox(strWorkbookName & " already exists. Do you want to overwrite?", vbYesNo, "Overwrite?")
            If intResponse = vbYes Then
                blnContinue = True
                Kill strSaveFolder & "\" & strWorkbookName
            End If
        Else
            blnContinue = True
        End If
        If blnContinue = True Then
            ActiveWorkbook.SaveAs strSaveFolder & "\" & strWorkbookName, xlNormal
            MsgBox strWorkbookName & " has been created in " & strSaveFolder
        Else
            MsgBox "File has not been overwritten."
        End If
    Else
        MsgBox "The workbook has not been saved.  Please save it to use this feature."
    End If
End Sub

Open in new window


but if you want to put it into an add in, so you can use it from a custom tab on the ribbon, change this line:
Sub SaveAsJPG()

Open in new window


to this:
Sub SaveAsJPG(ByVal control As IRibbonControl)

Open in new window


Regards,

Rob.
CERTIFIED EXPERT
Most Valuable Expert 2012
Top Expert 2014

Commented:
Oh, the macro doesn't need to be called SaveAsJPG....probably better of as ArchiveFileToFolder or something...

Author

Commented:
Yep good one Rob, thanks.

One thing though, I cannot overwrite an existing file. It prompts me for overwrite, but when I click yes it errors:

Run-time error '70':

Permission denied.

Now I have checked the security on that directory and there is nothing preventing this. If I overwrite the file through Excel manually (File -> Save As) it works no problems.

When I click debug, it is telling me there is a problem with the following line:


Kill strSaveFolder & "\" & strWorkbookName

Open in new window

CERTIFIED EXPERT
Most Valuable Expert 2012
Top Expert 2014

Commented:
I think you must be running a macro from a file that is already in that folder.  This means you can't delete (Kill) the file that is currently open.

I'll just make a quick change....it won't need to use Kill....we can just overwrite...
CERTIFIED EXPERT
Most Valuable Expert 2012
Top Expert 2014

Commented:
Try this.  A bit cleaner.

Rob.
Sub ArchiveFile()
    If InStr(ActiveWorkbook.Name, ".") > 0 Then
        strWorkbookName = ActiveWorkbook.Name
        strSaveFolder = "C:\Daily Insight Report Files\"
        If Right(strSaveFolder, 1) = "\" Then strSaveFolder = Left(strSaveFolder, Len(strSaveFolder) - 1)
        If Dir(strSaveFolder, vbDirectory) = "" Then MkDir strSaveFolder
        If Dir(strSaveFolder & "\" & strWorkbookName) <> "" Then
            intResponse = MsgBox(strWorkbookName & " already exists. Do you want to overwrite?", vbYesNo, "Overwrite?")
            If intResponse = vbYes Then
                Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs strSaveFolder & "\" & strWorkbookName, xlNormal
                Application.DisplayAlerts = True
            Else
                MsgBox "File has not been overwritten."
            End If
        Else
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs strSaveFolder & "\" & strWorkbookName, xlNormal
            Application.DisplayAlerts = True
            MsgBox strWorkbookName & " has been created in " & strSaveFolder
        End If
    Else
        MsgBox "The workbook has not been saved.  Please save it to use this feature."
    End If
End Sub

Open in new window

Author

Commented:
Yep great, almost there! Just one final bit of logic, when the file is overwritten, can we advise the user that the file has been overwritten??
Wrong number of arguments (Error 450) 

The number of arguments to a procedure must match the number of parameters in the procedure's definition. This error has the following causes and solutions:


The number of arguments in the call to the procedure wasn't the same as the number of required arguments expected by the procedure. 
Check the argument list in the call against the procedure declaration or definition.

You specified an index for a control that isn't part of a control array.
The index specification is interpreted as an argument but neither an index nor an argument is expected, so the error occurs. Remove the index specification, or follow the procedure for creating a control array. Set the Index property to a nonzero value in the control's property sheet or property window at design time.

You tried to assign a value to a read-only property, or you tried to assign a value to a property for which no Property Let procedure exists. 
Assigning a value to a property is the same as passing the value as an argument to the object's Property Let procedure. Properly define the Property Let procedure; it must have one more argument than the corresponding Property Get procedure. If the property is meant to be read-only, you can't assign a value to it.

Open in new window

Author

Commented:
Disregard that bit of code...
CERTIFIED EXPERT
Most Valuable Expert 2012
Top Expert 2014
Commented:
Yep, sure.

Rob.
Sub ArchiveFile()
    If InStr(ActiveWorkbook.Name, ".") > 0 Then
        strWorkbookName = ActiveWorkbook.Name
        strSaveFolder = "C:\Daily Insight Report Files\"
        If Right(strSaveFolder, 1) = "\" Then strSaveFolder = Left(strSaveFolder, Len(strSaveFolder) - 1)
        If Dir(strSaveFolder, vbDirectory) = "" Then MkDir strSaveFolder
        If Dir(strSaveFolder & "\" & strWorkbookName) <> "" Then
            intResponse = MsgBox(strWorkbookName & " already exists. Do you want to overwrite?", vbYesNo, "Overwrite?")
            If intResponse = vbYes Then
                Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs strSaveFolder & "\" & strWorkbookName, xlNormal
                Application.DisplayAlerts = True
                MsgBox strWorkbookName & " has been overwritten in " & strSaveFolder
            Else
                MsgBox "File has not been overwritten."
            End If
        Else
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs strSaveFolder & "\" & strWorkbookName, xlNormal
            Application.DisplayAlerts = True
            MsgBox strWorkbookName & " has been created in " & strSaveFolder
        End If
    Else
        MsgBox "The workbook has not been saved.  Please save it to use this feature."
    End If
End Sub

Open in new window

Author

Commented:
Legend!