Why am I seeing a Run-time Error 1004

aknox6

New Member
Joined
Sep 25, 2017
Messages
6
I have created a macro that takes one file, parses the data in to separate tabs, then takes those individual tabs and paste them into a format for another file (Appendix A), and saves it as a PDF / XLSX based off the following file format: Appendix A_Name_Client Name_Effective Date.

I am running into the error where I am receiving a Run-Time Error 1004 (see below). The "AA" file is saved under: C:\Temp\AA.xlsx, and the the folder it references to save the file is also there. I was running into the error where I was seeing a Run-Time Error 1004, and now I am just seeing an error that says Run - Time Error 53 "file not found". <v:shapetype id="_x0000_t75" stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" o:preferrelative="t" o:spt="75" coordsize="21600,21600"><v:stroke joinstyle="miter"><v:formulas><v:f eqn="if lineDrawn pixelLineWidth 0"><v:f eqn="sum @0 1 0"><v:f eqn="sum 0 0 @1"><v:f eqn="prod @2 1 2"><v:f eqn="prod @3 21600 pixelWidth"><v:f eqn="prod @3 21600 pixelHeight"><v:f eqn="sum @0 0 1"><v:f eqn="prod @6 1 2"><v:f eqn="prod @7 21600 pixelWidth"><v:f eqn="sum @8 21600 0">
</v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:formulas>
</v:stroke></v:shapetype>

The code is below. Since both files are there, I am unsure what is causing this.

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 #filenum
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



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
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
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
' ActiveCell.FormulaR1C1 = _
' "=VLOOKUP(R[1]C,'[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C[-8]:C[-6],3,FALSE)"
' Range("I1").Select
' ActiveCell.FormulaR1C1 = _
' "=INDEX('[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C2,MATCH(R[2]C,'[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C1,0))"
' Range("E3").Select
' ActiveCell.FormulaR1C1 = _
' "=VLOOKUP(RC[4],'[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C[-4]:C[-1],3,FALSE)"
' Range("E4").Select



'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, "DD/MMM/YYYY")
'File name should be like AppendixA_Carrier Name_Client Name_Date
'Save as PDF file
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
Save_Path_PDF_XLS & "" & Prefix & carrier & "_" & name & "_" & datum & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
'--------------------------------------------------------------------------------------------------------
'Save as XLSX file
ActiveWorkbook.SaveAs filename:=Save_Path_PDF_XLS & "" & Prefix & carrier & "_" & name & "_" & datum & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'Closing without saving Template file
ActiveWorkbook.Close savechanges:=False
End With
kraj:
End If
Next ws
zadnja:
End Sub





Thanks!
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Which line is causing the error? Also, make sure to use the CODE tags when posting VBA code.

I took a stab at formatting your code.
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
    Dim 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
     Dim WrkBk_to As String
     Dim WrkBk_Path As String
     Dim Save_Path_PDF_XLS As String
     Dim datum As String
     Dim carrier As String
     Dim name As String
     Dim appa 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
            .Activate
            If (.name <> "Award") And (.name <> "Appendix A") And (.name <> "Lookup") And (.name <> "Unique") Then
                Range("M1").FormulaR1C1 = "=ISNUMBER(MATCH(R2C2,Lookup!C[-12],0))"
                If Not Range("M1").Value Then
                    Odgovor1 = MsgBox("SCAC NOT MATCHED! Please correct this", vbCritical, "SCAC NOT MATCHED!")
                    GoTo zadnja
                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
                    .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
                    'checks if cell is empty, if true do not save file, goes to next worksheet
                    If Len(Range("B2")) < 4 Then GoTo kraj:
                        Range("B2").Copy
                        'Activates Apendix A
                        Windows(WrkBk_to).Activate
                        Range("E4").Paste
                        Rows("4:4").EntireRow.Hidden = True
                        ' Range("I3").Select
                        ' ActiveCell.FormulaR1C1 = "=R[1]C[-4]"
                        ' Range("I2").Select
                        ' ActiveCell.FormulaR1C1 = _
                        ' "=VLOOKUP(R[1]C,'[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C[-8]:C[-6],3,FALSE)"
                        ' Range("I1").Select
                        ' ActiveCell.FormulaR1C1 = _
                        ' "=INDEX('[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C2,MATCH(R[2]C,'[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C1,0))"
                        ' Range("E3").Select
                        ' ActiveCell.FormulaR1C1 = _
                        ' "=VLOOKUP(RC[4],'[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C[-4]:C[-1],3,FALSE)"
                        ' Range("E4").Select
                        
                        
                        
                        'copypaste9692() copies C:K from award file and paste into template
                        Windows(WrkBk_from).Activate 'Activates this workbook
                        Range("C2", Selection.End(xlToRight), Selection.End(xlDown)).Copy
                        Windows(WrkBk_to).Activate
                        Range("A15").Insert Shift:=xlDown
            
                        With Range("A15", Selection.End(xlToRight), Selection.End(xlDown))
                        'Removing formatting
                            .Borders(xlDiagonalDown).LineStyle = xlNone
                            .Borders(xlDiagonalUp).LineStyle = xlNone
                            .Borders(xlEdgeLeft).LineStyle = xlNone
                            .Borders(xlEdgeBottom).LineStyle = xlNone
                            With .Borders(xlEdgeTop)
                                .LineStyle = xlDouble
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThick
                            End With
                            .Borders(xlEdgeRight).LineStyle = xlNone
                            .Borders(xlInsideVertical).LineStyle = xlNone
                            .Borders(xlInsideHorizontal).LineStyle = xlNone
                        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
                        '---------------------------------------------------------
                        '----------------------------------------------------------------------------------------
            
                        '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
                        'Finding cell with date
                        Cells.Find(What:="Effective Date:", After:=Range("H12"), LookIn:=xlValues, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False).Activate
                        datum = Format(ActiveCell, "DD/MMM/YYYY")
                        'File name should be like AppendixA_Carrier Name_Client Name_Date
                        'Save as PDF file
                        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
                            Save_Path_PDF_XLS & "" & Prefix & carrier & "_" & name & "_" & datum & ".pdf" _
                            , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
                            :=False, OpenAfterPublish:=False
                        '--------------------------------------------------------------------------------------------------------
                        'Save as XLSX file
                        ActiveWorkbook.SaveAs filename:=Save_Path_PDF_XLS & "" & Prefix & carrier & "_" & name & "_" & datum & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                        'Closing without saving Template file
                        ActiveWorkbook.Close savechanges:=False
                    End If
                End If
            End With
kraj:
         End If
     Next ws
zadnja:
End Sub

I also changed some of the syntax around to hopefully make it more efficient (I may have caused more harm than good, though). When I see the "Select/Selection/ActiveCell" syntax, my OCD kicks in; it's like a guilty pleasure to clean code once in a while.
 
Upvote 0
Which line is causing the error? Also, make sure to use the CODE tags when posting VBA code.

I took a stab at formatting your code.
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
    Dim 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
     Dim WrkBk_to As String
     Dim WrkBk_Path As String
     Dim Save_Path_PDF_XLS As String
     Dim datum As String
     Dim carrier As String
     Dim name As String
     Dim appa 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
            .Activate
            If (.name <> "Award") And (.name <> "Appendix A") And (.name <> "Lookup") And (.name <> "Unique") Then
                Range("M1").FormulaR1C1 = "=ISNUMBER(MATCH(R2C2,Lookup!C[-12],0))"
                If Not Range("M1").Value Then
                    Odgovor1 = MsgBox("SCAC NOT MATCHED! Please correct this", vbCritical, "SCAC NOT MATCHED!")
                    GoTo zadnja
                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
                    .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
                    'checks if cell is empty, if true do not save file, goes to next worksheet
                    If Len(Range("B2")) < 4 Then GoTo kraj:
                        Range("B2").Copy
                        'Activates Apendix A
                        Windows(WrkBk_to).Activate
                        Range("E4").Paste
                        Rows("4:4").EntireRow.Hidden = True
                        ' Range("I3").Select
                        ' ActiveCell.FormulaR1C1 = "=R[1]C[-4]"
                        ' Range("I2").Select
                        ' ActiveCell.FormulaR1C1 = _
                        ' "=VLOOKUP(R[1]C,'[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C[-8]:C[-6],3,FALSE)"
                        ' Range("I1").Select
                        ' ActiveCell.FormulaR1C1 = _
                        ' "=INDEX('[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C2,MATCH(R[2]C,'[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C1,0))"
                        ' Range("E3").Select
                        ' ActiveCell.FormulaR1C1 = _
                        ' "=VLOOKUP(RC[4],'[" & WrkBk_Path & "" & WrkBk_from & "]Lookup'!C[-4]:C[-1],3,FALSE)"
                        ' Range("E4").Select
                        
                        
                        
                        'copypaste9692() copies C:K from award file and paste into template
                        Windows(WrkBk_from).Activate 'Activates this workbook
                        Range("C2", Selection.End(xlToRight), Selection.End(xlDown)).Copy
                        Windows(WrkBk_to).Activate
                        Range("A15").Insert Shift:=xlDown
            
                        With Range("A15", Selection.End(xlToRight), Selection.End(xlDown))
                        'Removing formatting
                            .Borders(xlDiagonalDown).LineStyle = xlNone
                            .Borders(xlDiagonalUp).LineStyle = xlNone
                            .Borders(xlEdgeLeft).LineStyle = xlNone
                            .Borders(xlEdgeBottom).LineStyle = xlNone
                            With .Borders(xlEdgeTop)
                                .LineStyle = xlDouble
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThick
                            End With
                            .Borders(xlEdgeRight).LineStyle = xlNone
                            .Borders(xlInsideVertical).LineStyle = xlNone
                            .Borders(xlInsideHorizontal).LineStyle = xlNone
                        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
                        '---------------------------------------------------------
                        '----------------------------------------------------------------------------------------
            
                        '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
                        'Finding cell with date
                        Cells.Find(What:="Effective Date:", After:=Range("H12"), LookIn:=xlValues, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False).Activate
                        datum = Format(ActiveCell, "DD/MMM/YYYY")
                        'File name should be like AppendixA_Carrier Name_Client Name_Date
                        'Save as PDF file
                        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
                            Save_Path_PDF_XLS & "" & Prefix & carrier & "_" & name & "_" & datum & ".pdf" _
                            , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
                            :=False, OpenAfterPublish:=False
                        '--------------------------------------------------------------------------------------------------------
                        'Save as XLSX file
                        ActiveWorkbook.SaveAs filename:=Save_Path_PDF_XLS & "" & Prefix & carrier & "_" & name & "_" & datum & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                        'Closing without saving Template file
                        ActiveWorkbook.Close savechanges:=False
                    End If
                End If
            End With
kraj:
         End If
     Next ws
zadnja:
End Sub

I also changed some of the syntax around to hopefully make it more efficient (I may have caused more harm than good, though). When I see the "Select/Selection/ActiveCell" syntax, my OCD kicks in; it's like a guilty pleasure to clean code once in a while.


Thank you for doing that. Im still not having any luck though. the "Error Errnum" line is highlighted as causing the issue.
 
Upvote 0
Either add the ".Number" to the end of "Err" or just replace the whole line.
 
Upvote 0

Forum statistics

Threads
1,213,560
Messages
6,114,306
Members
448,564
Latest member
ED38

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