Run Time Error 53 Code

aknox6

New Member
Joined
Sep 25, 2017
Messages
6
Can someone please help with this code. I have a file "AA" that I am looking to take data from my larger file, have it pasted into this file in a certain format and save the data in a certain naming convention as an XLSX and a PDF. However, I am having lots of trouble with this. I have the code below, but I am currently receiving a runtime error 53. Even though the file, I am referencing seems to be in the location that it is referenced in the code. I was receiving a 1004 error, had someone help me make some adjustments to the code and now I am receiving a run time error 53.
Code:
Function IsFileOpen(filename As String)
    'Checking if file is open, returns True if it is
    'file is specified in name of function when you call it
    'like IsFileOpen("C:\Temp\AA.xlsx")
    Dim filenum As Integer, errnum As Integer
    On Error Resume Next   ' Turn error checking off.
    filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open filename For Input Lock Read As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=filenum"]#filenum[/URL] 
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.
    ' Check to see which error occurred.
    Select Case errnum
        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True
        ' Another error occurred.
        Case Else
            Error errnum
    End Select
End Function
Sub a_Guru_Loop()
 'Loop - Appendix A Workbook must also be open for this to run
 'I assume that Appendix A is in same directory as this file, if not it must be
 
            Dim ws As Worksheet
            Dim WrkBk_from As String, WrkBk_to As String, WrkBk_Path As String, Save_Path_PDF_XLS As String
            Dim datum, carrier, name, appa As String, vFormula As String
            
            
            
            WrkBk_from = ThisWorkbook.name
            WrkBk_Path = ThisWorkbook.Path
            WrkBk_to = "Appendix A.xlsm"
            'Prefix = "Appendix_A_" 'prefix to file name
            Prefix = InputBox("Prefix to file name", "Prefix only", "Appendix_A_")
                If Prefix = vbNullString Then
                        MsgBox ("User canceled!")
                        GoTo zadnja
                End If
            Save_Path_PDF_XLS = InputBox("Path where to save PDF(s)", "Full Path without \ at end", "C:\Temp\! BCKup T disk")
                If Save_Path_PDF_XLS = vbNullString Then
                        MsgBox ("User canceled!")
                        GoTo zadnja
                End If
'*******************************************************************************
'Checks if SCAC is matching with lookup sheet
     For Each ws In Workbooks(WrkBk_from).Worksheets
        With ws
            ws.Activate
            Range("M1").Select
            If (ws.name <> "Award") And (ws.name <> "Appendix A") And (ws.name <> "Lookup") And (ws.name <> "Unique") Then
                ActiveCell.FormulaR1C1 = "=ISNUMBER(MATCH(R2C2,Lookup!C[-12],0))"
                If Not ActiveCell Then
                    Odgovor1 = MsgBox("SCAC NOT MATCHED! Please correct this", vbCritical, "SCAC NOT MATCHED!")
                    GoTo zadnja
                Else
                    ActiveCell.Value = ""
                End If
            End If
        End With
    Next ws
'----------------------------------------------------------------
For Each ws In Workbooks(WrkBk_from).Worksheets
        'If worksheet like Award, Apendix, Lookup, Unique then skip to next. Original is belowe, missed Unique
        'If (ws.name <> "Award") And (ws.name <> "Appendix A") And (ws.name <> "Lookup") Then
        If (ws.name <> "Award") And (ws.name <> "Appendix A") And (ws.name <> "Lookup") And (ws.name <> "Unique") Then
                    carrier = ""
                    name = ""
                    appa = ""
                    datum = ""
            With ws
'Copies data from Award Template Workbook and Paste into Appendix A Workbook
            
                    'Check if ifle is open if not it opens file, must have NOT infront so that If will work in case Workbook is not opened
                    If Not (IsFileOpen(WrkBk_Path & "" & WrkBk_to)) Then Workbooks.Open (WrkBk_Path & "" & WrkBk_to)
            ' copypaste9261 Macro
            Windows(WrkBk_from).Activate
            ws.Activate
'This was original, but this setting caused problems.
'If you are using Carrier name, every char is important, so if there is , with space after and
'your reference is haveing name with , but without space you can not use vlookup
'MUCH better is to use SCAC since it is unique and simple
                'Range("A2").Select
            Range("B2").Select
'checks if cell is empty, if true do not save file, goes to next worksheet
            If Len(Range("B2")) < 4 Then GoTo kraj:
            Selection.Copy
'Activates Apendix A
'All formulas are delete from this file since
'this maybe causing problems; this code is inserting relavant formulas
            Windows(WrkBk_to).Activate
            Range("E4").Select
            ActiveSheet.Paste
            Rows("4:4").Select
            Selection.EntireRow.Hidden = True
            
                        Range("I3").Select
                        ActiveCell.FormulaR1C1 = "=R[1]C[-4]"
                        Range("I2").Select
                            vFormula = "=VLOOKUP(R[1]C,'[" & WrkBk_from & "]Lookup'!C1:C3,3,FALSE)"
                         ActiveCell.FormulaR1C1 = vFormula
'                        ActiveCell.FormulaR1C1 = _
'                            "=VLOOKUP(R[1]C,'[Final Macro To Run.xlsm]Lookup'!C1:C3,3,FALSE)"
                        Range("I1").Select
                            vFormula = "=INDEX('[" & WrkBk_from & "]Lookup'!C2,MATCH(R[2]C,'[" & WrkBk_from & "]Lookup'!C1,0))"
                        ActiveCell.FormulaR1C1 = vFormula
'                        ActiveCell.FormulaR1C1 = _
'                            "=INDEX('[Final Macro To Run.xlsm]Lookup'!C2,MATCH(R[2]C,'[Final Macro To Run.xlsm]Lookup'!C1,0))"
                        Range("E3").Select
                            vFormula = "=VLOOKUP(RC[4],'[" & WrkBk_from & "]Lookup'!C1:C4,3,FALSE)"
                        ActiveCell.FormulaR1C1 = vFormula
'                        ActiveCell.FormulaR1C1 = _
'                            "=VLOOKUP(RC[4],'[Final Macro To Run.xlsm]Lookup'!C1:C4,3,FALSE)"
                        Range("E7").Select
                        Range("A17").Select
                            vFormula = "=VLOOKUP(R[-14]C[8],'[" & WrkBk_from & "]Lookup'!C1:C2,2,FALSE)"
                        ActiveCell.FormulaR1C1 = vFormula
'                        ActiveCell.FormulaR1C1 = _
'                            "=VLOOKUP(R[-14]C[8],'[Final Macro To Run.xlsm]Lookup'!C1:C2,2,FALSE)"
            'copypaste9692() copies C:K from award file and paste into template
            Windows(WrkBk_from).Activate 'Activates this workbook
            Range("C2").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Windows(WrkBk_to).Activate
            Range("A15").Select
            Selection.Insert Shift:=xlDown
            
            Range("A15").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Range(Selection, Selection.End(xlDown)).Select
'Removing formatting
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            Selection.Borders(xlEdgeLeft).LineStyle = xlNone
            Selection.Borders(xlEdgeBottom).LineStyle = xlNone
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlDouble
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThick
            End With
'If you want to mark end of data un comment this
        '            With Selection.Borders(xlEdgeBottom)
        '                .LineStyle = xlContinuous
        '                .ColorIndex = xlAutomatic
        '                .TintAndShade = 0
        '                .Weight = xlThin
        '            End With
'---------------------------------------------------------
            Selection.Borders(xlEdgeRight).LineStyle = xlNone
            Selection.Borders(xlInsideVertical).LineStyle = xlNone
            Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'----------------------------------------------------------------------------------------
            
            
            
            ActiveWindow.SmallScroll Down:=0
        
            'Saves the copied cells in the Appendix A as a New Workbook with the Name being a Cell Value (E4)
'This was for original file
'            carrier = Range("E4").Value
'            name = Range("E3").Value
'            appa = Range("E1").Value
'--------------------------------------------
            carrier = Range("I1").Value
            name = Range("I2").Value
            appa = Range("I3").Value
            Range("H12").Select
            'Finding cell with date
            Cells.Find(What:="Effective Date:", After:=ActiveCell, LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False).Activate
           ActiveCell.Offset(0, 1).Select
           datum = Format(ActiveCell, "YYYY-MM-DD")
'File name should be like AppendixA_Carrier Name_Client Name_Date
'Saves as XLSM
            Workbooks(WrkBk_to).Activate
'            ActiveWorkbook.SaveAs filename:=Save_Path_PDF_XLS & "" & Prefix & carrier & "_" & name & "_" & datum & ".xlsm", FileFormat:=52  'Save as macro enabled Excel file
'--------------------------------------------------------------------------------------------------------
'Save as PDF file
'            ActiveWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
'            Save_Path_PDF_XLS & "" & appa & "_" & datum & ".pdf" _
'                , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
'                :=False, OpenAfterPublish:=False
'--------------------------------------------------------------------------------------------------------
'Save as XLSX file
            ActiveWorkbook.SaveAs filename:=Save_Path_PDF_XLS & "" & appa & "_" & name & "_" & datum & ".xlsx", FileFormat:=51, CreateBackup:=False
'--------------------------------------------------------------------------------------------------------
'Save as XLSB file
            ActiveWorkbook.SaveAs filename:=Save_Path_PDF_XLS & "" & Prefix & carrier & "_" & name & "_" & datum & ".xlsb", FileFormat:=50, CreateBackup:=False
'--------------------------------------------------------------------------------------------------------
'Closing without saving Template file
            ActiveWorkbook.Close savechanges:=False
            End With
kraj:
        End If
    Next ws
zadnja:
 End Sub
 
Last edited:

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.

Forum statistics

Threads
1,213,492
Messages
6,113,967
Members
448,537
Latest member
Et_Cetera

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top