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
referrelative="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!
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
referrelative="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!
