excel - VB Macro returns Error 1004 when run from PERSONAL.XLSB - Stack Overflow

admin管理员组

文章数量:1388146

I've got my code from a previous query working. The macro looks up a value in another worksheet, then renames the first file based on the lookup value.

This Macro needs to be run regularly on various files that we are sent. In order to facilitate this, I saved the Macro to PERSONAL.XLSB so it would be available to use in any Excel file I open. The code is exactly the same.

When I try to run the Macro via PERSONAL.XLSB I get Runt-time error 1004: This extension can not be used with the selected file type. Change the file extension in the File name text box or select a different file type by changing the save as type.

This only happens when I run the macro via PERSONAL.XLSB, not when I run the module saved in the workbook.

Any ideas? I am stumped! The file I am running the macro on is a xlsm.

Code below

Sub LookupAndRenameWorkbook5()
    Dim lookupValue As Variant
    Dim foundValue As Variant
    Dim sumY As Double
    Dim fcaFilePath As String
    Dim fcaWorkbook As Workbook
    Dim fcaSheet As Worksheet
    Dim lastRow As Long
    Dim dataObj As Object
  
    ' Set the lookup value from column G (assuming the first cell in G2)
    lookupValue = (ThisWorkbook.Sheets(1).Range("G2").Value) ' Trim to remove any leading/trailing spaces
  
    ' Specify the file path for the FCA Register workbook
    fcaFilePath = "\\Path\FINANCE\Commissions\FCA Register for Look Up.xlsx" ' Update this path accordingly
  
    ' Open the FCA Register workbook
    Set fcaWorkbook = Workbooks.Open(fcaFilePath)
    Set fcaSheet = fcaWorkbook.Sheets("Sheet1") ' Reference to Sheet1
  
    ' Find the lookup value in column A of Sheet1
    On Error Resume Next
    foundValue = Application.VLookup(lookupValue, fcaSheet.Range("A:B"), 2, False)
    On Error GoTo 0
  
    ' Check if foundValue is still an error
    If IsError(foundValue) Then
        Debug.Print "Value not found in FCA Register."
    Else
        Debug.Print "Found Value: [" & foundValue & "]"
    End If
  
    ' Sum the contents of column Y in the current workbook
    lastRow = ThisWorkbook.Sheets(1).Cells(ThisWorkbook.Sheets(1).Rows.Count, "Y").End(xlUp).Row
    sumY = Application.WorksheetFunction.Sum(ThisWorkbook.Sheets(1).Range("Y1:Y" & lastRow))
  
    ' Construct the new file name using the found value and the sum of Y
    Dim newFileName As String
    If Not IsError(foundValue) Then
        newFileName = foundValue & " " & sumY & ".xlsm"
    Else
        newFileName = "NoMatch " & sumY & ".xlsm"  ' Default name if no match is found
    End If
  
    ' Save the existing workbook with the new name in the same directory
    ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & newFileName ' Save in the same directory
  
    ' Close the FCA Register workbook without saving
    fcaWorkbook.Close SaveChanges:=False
  
    ' Inform the user if the lookup value was not found
    If IsError(foundValue) Then
        MsgBox "Value not found in FCA Register."
    End If
  
    ' Clean up
    Set fcaSheet = Nothing
    Set fcaWorkbook = Nothing
    Set dataObj = Nothing
End Sub

I've got my code from a previous query working. The macro looks up a value in another worksheet, then renames the first file based on the lookup value.

This Macro needs to be run regularly on various files that we are sent. In order to facilitate this, I saved the Macro to PERSONAL.XLSB so it would be available to use in any Excel file I open. The code is exactly the same.

When I try to run the Macro via PERSONAL.XLSB I get Runt-time error 1004: This extension can not be used with the selected file type. Change the file extension in the File name text box or select a different file type by changing the save as type.

This only happens when I run the macro via PERSONAL.XLSB, not when I run the module saved in the workbook.

Any ideas? I am stumped! The file I am running the macro on is a xlsm.

Code below

Sub LookupAndRenameWorkbook5()
    Dim lookupValue As Variant
    Dim foundValue As Variant
    Dim sumY As Double
    Dim fcaFilePath As String
    Dim fcaWorkbook As Workbook
    Dim fcaSheet As Worksheet
    Dim lastRow As Long
    Dim dataObj As Object
  
    ' Set the lookup value from column G (assuming the first cell in G2)
    lookupValue = (ThisWorkbook.Sheets(1).Range("G2").Value) ' Trim to remove any leading/trailing spaces
  
    ' Specify the file path for the FCA Register workbook
    fcaFilePath = "\\Path\FINANCE\Commissions\FCA Register for Look Up.xlsx" ' Update this path accordingly
  
    ' Open the FCA Register workbook
    Set fcaWorkbook = Workbooks.Open(fcaFilePath)
    Set fcaSheet = fcaWorkbook.Sheets("Sheet1") ' Reference to Sheet1
  
    ' Find the lookup value in column A of Sheet1
    On Error Resume Next
    foundValue = Application.VLookup(lookupValue, fcaSheet.Range("A:B"), 2, False)
    On Error GoTo 0
  
    ' Check if foundValue is still an error
    If IsError(foundValue) Then
        Debug.Print "Value not found in FCA Register."
    Else
        Debug.Print "Found Value: [" & foundValue & "]"
    End If
  
    ' Sum the contents of column Y in the current workbook
    lastRow = ThisWorkbook.Sheets(1).Cells(ThisWorkbook.Sheets(1).Rows.Count, "Y").End(xlUp).Row
    sumY = Application.WorksheetFunction.Sum(ThisWorkbook.Sheets(1).Range("Y1:Y" & lastRow))
  
    ' Construct the new file name using the found value and the sum of Y
    Dim newFileName As String
    If Not IsError(foundValue) Then
        newFileName = foundValue & " " & sumY & ".xlsm"
    Else
        newFileName = "NoMatch " & sumY & ".xlsm"  ' Default name if no match is found
    End If
  
    ' Save the existing workbook with the new name in the same directory
    ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & newFileName ' Save in the same directory
  
    ' Close the FCA Register workbook without saving
    fcaWorkbook.Close SaveChanges:=False
  
    ' Inform the user if the lookup value was not found
    If IsError(foundValue) Then
        MsgBox "Value not found in FCA Register."
    End If
  
    ' Clean up
    Set fcaSheet = Nothing
    Set fcaWorkbook = Nothing
    Set dataObj = Nothing
End Sub

• excel
• vba

Share Improve this question Follow edited Mar 17 at 11:03 JohnM 3,37044 gold badges1313 silver badges2828 bronze badges asked Mar 17 at 10:01 HelixAuHelixAu 2122 bronze badges 2

• Which line produces that error – CHill60 Commented Mar 17 at 11:11
• ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & newFileName ' – HelixAu Commented Mar 17 at 11:21

Add a comment  | 

1 Answer 1

Sorted by: Reset to default 1

Backup Workbook

A Quick Fix

• ThisWorkbook is the workbook containing the code, in this case, PERSONAL.xlsb. Either specify the workbook by name or use ActiveWorkbook.
• When saving a file, it is good practice (often mandatory) to specify the correct file format to avoid the error you're receiving (PERSONAL.xlsb is tried to be saved as a .xlsm file).
• Note that the benefit of using the late-bound versions of the worksheet functions (when using Application. instead of WorksheetFunction.) is that they just return error values when failing. They don't raise an error at run-time, i.e., the On Error Resume Next is redundant. Also, Application.Sum will return an error if any of the cells contain an error, i.e., maybe you need to accommodate for this.

Sub LookupAndRenameWorkbook5()
    
    ' Specify the file path for the FCA Register workbook
    Const SRC_FILE_PATH As String = _
        "\\Path\FINANCE\Commissions\FCA Register for Look Up.xlsx"
    
    ' Reference the destination workbook.
    Dim dwb As Workbook: Set dwb = ActiveWorkbook ' the one you're looking at
    ' Or:
    'Dim dwb As Workbook: Set dwb = Workbooks("Current.xlsm") ' you know its name
    
    ' Reference the destination worksheet.
    Dim dws As Worksheet: Set dws = dwb.Sheets(1)
    
    ' Set the lookup value from column G (assuming the first cell in G2)
    Dim LookupValue As Variant:
    LookupValue = dws.Range("G2").Value ' Trim to remove any leading/trailing spaces
    
    ' Open the FCA Register workbook
    Dim swb As Workbook: Set swb = Workbooks.Open(SRC_FILE_PATH)
    Dim sws As Worksheet: Set sws = swb.Sheets("Sheet1")
    
    ' Find the lookup value in column A of Sheet1
    Dim FoundValue As Variant:
    FoundValue = Application.VLookup(LookupValue, sws.Range("A:B"), 2, False)
    
    ' Sum the contents of column Y in the current workbook
    Dim LastRow As Long:
    LastRow = dws.Cells(dws.Rows.Count, "Y").End(xlUp).Row
    Dim SumAsString As String: ' assuming there are no errors in column `Y`!!!
    SumAsString = CStr(Application.Sum(dws.Range("Y1:Y" & LastRow)))
    
    Dim NewFileName As String:
    If IsError(FoundValue) Then
        ' Construct the new file name using a string.
        NewFileName = "NoMatch " & SumAsString & ".xlsm"  ' Default name if no match is found
        Debug.Print "Found Value: [" & CStr(FoundValue) & "]"
    Else
        ' Construct the new file name using the found value and the sum of Y
        NewFileName = FoundValue & " " & SumAsString & ".xlsm"
        Debug.Print "Value not found in FCA Register."
    End If
    
    ' Save the existing workbook with the new name in the same directory
    dwb.SaveAs dwb.Path & "\" & NewFileName, xlOpenXMLWorkbookMacroEnabled
    
    ' Close the FCA Register workbook without saving
    swb.Close SaveChanges:=False
    
    ' Inform the user if the lookup value was not found
    If IsError(FoundValue) Then
        MsgBox "Value not found in FCA Register."
    End If
    
End Sub

本文标签： excelVB Macro returns Error 1004 when run from PERSONALXLSBStack Overflow