I have a code (seen below at the bottom of this message) built by someone else and it has worked very well in excel 2010 but our administration migrated us to excel 2019. Now the same code produces errors. I have also tried checking if there were new add-ins or references in the reference library in vba but have not found anything that removes the errors or allows the code to execute properly.
The function of the code is basically like this:
The code is linked to a pivot table in a worksheet in a workbook. It will ask the user a few questions such as is this a 'RFQ' and then a msg box will open for them to enter a file name. It then asks the user if they wish to have the data added to another worksheet in the same workbook. After all these are answered the code should open an new workbook and copy/paste over data from a hidden worksheet from the original workbook into this new workbook. This new workbook should become the focus and allow the user to make any other changes before they save and close it.
The code automatically saved the new workbook in a location (using a HLink) that is referenced from a cell on another hidden worksheet in the original workbook.
The errors that take place now is this: "The following features cannot be saved in macro-free workbooks: VB Project To save a file with these features, click No, and then choose a macro-enabled file type in the File type list. To continue saving as a macro-free workbook, click Yes.
If the user says yes, the it says the new workbook that was just created 'already exists in this location. Do you want to replace it?"
If you say yes, everything goes blank and you have to restart excel. If you say no, the vba debugger opens to the end of the code highlighting the last part of the code:
ActiveWorkbook.SaveAs FileName:=HLink _ , FileFormat:"xlOpenXMLWorkbook, CreateBackup:=False
I have tried changing some sections of the code. From this:
`'Save
On Error GoTo ErrFileClose:
HLink = (FilePath & "\" & FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;@") & ".xlsx")
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If`
To this:
'Save
On Error GoTo ErrFileClose:
HLink = (FilePath & "\" & FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;@"))
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=51, CreateBackup:=False
End If
And similarly, from this:
'Check if previously created file is open and close it so new one can be saved
ErrFileClose:
FinalFileName = FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;@") & ".xlsx"
Workbooks(FinalFileName).Close SaveChanges:=True
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
To this:
'Check if previously created file is open and close it so new one can be saved
ErrFileClose:
FinalFileName = FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;@")
Workbooks(FinalFileName).Close SaveChanges:=True
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=51, CreateBackup:=False
These changes sometimes help and seem to remove the vb project error but it is not consistent every time I run the macro.
Any help is appreciated as we cannot move forward using this as it stands.
Thanks.
Sub ImportFile()
'
' ImportFile Macro
Call UnprotectAll
'Create Import
Dim curWorkbook As Workbook
Dim ReqType As String
Dim FileName As String
Dim FinalFileName As String
Dim FilePath As String
FilePath = Sheets("X").Range("C3").Value
Dim HLink As String
Application.ScreenUpdating = False
Sheets("Import").Visible = True
Sheets("Import").Copy
ActiveSheet.Unprotect
'Edit import to remove formulas and blank rows
Range("A1:AC500").Value = Range("A1:AC500").Value
Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set curWorkbook = ActiveWorkbook
Windows("Transactions.xlsm").Activate
Sheets("Import").Visible = False
curWorkbook.Activate
'Save Import
ReqType = MsgBox("Click YES if you are creating an RFQ", vbYesNoCancel)
'vbCancel = 2, vbYes = 6, vbNo = 7
If ReqType = 6 Then
ReqType = "RFQ"
Else
If ReqType = 7 Then
ReqType = "Ordered"
Else
Exit Sub
End If
End If
FileName = InputBox("Please enter the Incident number or other Unique ID Number to save this file as:")
'Cancel Save
If FileName = "" Then
ActiveWorkbook.Close SaveChanges:=False
Call ProtectAll
Application.ScreenUpdating = True
MsgBox ("File Not Created")
Exit Sub
Else
'Save
On Error GoTo ErrFileClose:
HLink = (FilePath & "\" & FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;@") & ".xlsx")
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
'Add Order to Receive tab ?
If MsgBox("Ok to add this data as Transaction: " & ReqType & "?", vbOKCancel) = vbOK Then
Windows("Transactions.xlsm").Activate
Else
'Do Not add Order to transactions Order - Receipt
ActiveWorkbook.Close SaveChanges:=False
Call ProtectAll
Application.ScreenUpdating = True
MsgBox ("This has not been added as a transaction. Click the HuB button when ready to try again. A new import file will be created and can be saved over the one just created.")
Exit Sub
End If
'AddOrder to Transactions Order - Receipt
ActiveSheet.PivotTables("ToBeOrderedPivot").RowRange.Select
'Remove headers and column 1
Selection.Offset(1, 1).Resize(Selection.Rows.Count - 1, _
Selection.Columns.Count).Select
'Remove Extra Columns
Dim FirstRow As Integer
Dim LastRow As Integer
FirstRow = Selection.Row
LastRow = FirstRow + Selection.Rows.Count - 1
Range("C" & FirstRow & ":F" & LastRow & ",AA" & FirstRow & ":AA" & LastRow & ",L" & FirstRow & ":L" & LastRow).Select
Selection.SpecialCells(xlCellTypeVisible).Copy
'Move to end of Orders table
Sheets("Receive").Select
Count = Range("Orders[Mtl ID]").Rows.Count
Range("B" & Count + 4).Select
'Paste Values
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Set Values
Selection.Offset(0, 8).Columns(1).Value = Selection.Offset(0, 2).Columns(1).Value
If ReqType = "RFQ" Then
Selection.Offset(0, 2).Columns(1).Value = 0
Selection.Offset(0, 7).Columns(1).Value = ReqType
Else: Selection.Offset(0, 2).Columns(1).Value = Selection.Offset(0, 5).Columns(1).Value
End If
Selection.Offset(0, 5).Columns(1).Value = Selection.Offset(0, 3).Columns(1).Value
Selection.Offset(0, 3).Columns(1).Value = Selection.Offset(0, 4).Columns(1).Value
Selection.Offset(0, 4).Columns(1).Value = Selection.Offset(0, 8).Columns(1).Value
Selection.Offset(0, 8).Columns(1).Value = FileName
Selection.Offset(0, 9).Columns(1).Value = Format(Date, "[$-409]yyyy-mm-d;@")
'Sort Table
Call SortReceive
Call ProtectAll
Application.ScreenUpdating = True
'Return to Import File
curWorkbook.Activate
Exit Sub
'Check if previously created file is open and close it so new one can be saved
ErrFileClose:
FinalFileName = FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;@") & ".xlsx"
Workbooks(FinalFileName).Close SaveChanges:=True
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Resume Next
End Sub
