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:
