Extract Data from PDF and Add to Worksheet - excel

I am trying to extract the data from a PDF document into a worksheet. The PDFs show and text can be manually copied and pasted into the Excel document.
I am currently doing this through SendKeys and it is not working. I get an error when I try to paste the data from the PDF document. Why is my paste not working? If I paste after the macro has stopped running it pastes as normal.
Dim myPath As String, myExt As String
Dim ws As Worksheet
Dim openPDF As Object
'Dim pasteData As MSForms.DataObject
Dim fCell As Range
'Set pasteData = New MSForms.DataObject
Set ws = Sheets("DATA")
If ws.Cells(ws.Rows.Count, "A").End(xlUp).Row > 1 Then Range("A3:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).ClearContents
myExt = "\*.pdf"
'When Scan Receipts Button Pressed Scan the selected folder/s for receipts
For Each fCell In Range(ws.Cells(1, 1), ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column))
myPath = Dir(fCell.Value & myExt)
Do While myPath <> ""
myPath = fCell.Value & "\" & myPath
Set openPDF = CreateObject("Shell.Application")
openPDF.Open (myPath)
Application.Wait Now + TimeValue("00:00:2")
SendKeys "^a"
Application.Wait Now + TimeValue("00:00:2")
SendKeys "^c"
'Application.Wait Now + TimeValue("00:00:2")
ws.Select
ActiveSheet.Paste
'pasteData.GetFromClipboard
'ws.Cells(3, 1) = pasteData.GetText
Exit Sub
myPath = Dir
Loop
Next fCell

You can open the PDF file and extract its contents using the Adobe library (which I believe you can download from Adobe as part of the SDK, but it comes with certain versions of Acrobat as well)
Make sure to add the Library to your references too (On my machine it is the Adobe Acrobat 10.0 Type Library, but not sure if that is the newest version)
Even with the Adobe library it is not trivial (you'll need to add your own error-trapping etc):
Function getTextFromPDF(ByVal strFilename As String) As String
Dim objAVDoc As New AcroAVDoc
Dim objPDDoc As New AcroPDDoc
Dim objPage As AcroPDPage
Dim objSelection As AcroPDTextSelect
Dim objHighlight As AcroHiliteList
Dim pageNum As Long
Dim strText As String
strText = ""
If (objAvDoc.Open(strFilename, "") Then
Set objPDDoc = objAVDoc.GetPDDoc
For pageNum = 0 To objPDDoc.GetNumPages() - 1
Set objPage = objPDDoc.AcquirePage(pageNum)
Set objHighlight = New AcroHiliteList
objHighlight.Add 0, 10000 ' Adjust this up if it's not getting all the text on the page
Set objSelection = objPage.CreatePageHilite(objHighlight)
If Not objSelection Is Nothing Then
For tCount = 0 To objSelection.GetNumText - 1
strText = strText & objSelection.GetText(tCount)
Next tCount
End If
Next pageNum
objAVDoc.Close 1
End If
getTextFromPDF = strText
End Function
What this does is essentially the same thing you are trying to do - only using Adobe's own library. It's going through the PDF one page at a time, highlighting all of the text on the page, then dropping it (one text element at a time) into a string.
Keep in mind what you get from this could be full of all kinds of non-printing characters (line feeds, newlines, etc) that could even end up in the middle of what look like contiguous blocks of text, so you may need additional code to clean it up before you can use it.
Hope that helps!

I know this is an old issue but I just had to do this for a project at work, and I am very surprised that nobody has thought of this solution yet:
Just open the .pdf with Microsoft word.
The code is a lot easier to work with when you are trying to extract data from a .docx because it opens in Microsoft Word. Excel and Word play well together because they are both Microsoft programs. In my case, the file of question had to be a .pdf file. Here's the solution I came up with:
Choose the default program to open .pdf files to be Microsoft Word
The first time you open a .pdf file with word, a dialogue box pops up claiming word will need to convert the .pdf into a .docx file. Click the check box in the bottom left stating "do not show this message again" and then click OK.
Create a macro that extracts data from a .docx file. I used MikeD's Code as a resource for this.
Tinker around with the MoveDown, MoveRight, and Find.Execute methods to fit the need of your task.
Yes you could just convert the .pdf file to a .docx file but this is a much simpler solution in my opinion.

Over time, I have found that extracting text from PDFs in a structured format is tough business. However if you are looking for an easy solution, you might want to consider XPDF tool pdftotext.
Pseudocode to extract the text would include:
Using SHELL VBA statement to extract the text from PDF to a temporary file using XPDF
Using sequential file read statements to read the temporary file contents into a string
Pasting the string into Excel
Simplified example below:
Sub ReadIntoExcel(PDFName As String)
'Convert PDF to text
Shell "C:\Utils\pdftotext.exe -layout " & PDFName & " tempfile.txt"
'Read in the text file and write to Excel
Dim TextLine as String
Dim RowNumber as Integer
Dim F1 as Integer
RowNumber = 1
F1 = Freefile()
Open "tempfile.txt" for Input as #F1
While Not EOF(#F1)
Line Input #F1, TextLine
ThisWorkbook.WorkSheets(1).Cells(RowNumber, 1).Value = TextLine
RowNumber = RowNumber + 1
Wend
Close #F1
End Sub

Since I do not prefer to rely on external libraries and/or other programs, I have extended your solution so that it works.
The actual change here is using the GetFromClipboard function instead of Paste which is mainly used to paste a range of cells.
Of course, the downside is that the user must not change focus or intervene during the whole process.
Dim pathPDF As String, textPDF As String
Dim openPDF As Object
Dim objPDF As MsForms.DataObject
pathPDF = "C:\some\path\data.pdf"
Set openPDF = CreateObject("Shell.Application")
openPDF.Open (pathPDF)
'TIME TO WAIT BEFORE/AFTER COPY AND PASTE SENDKEYS
Application.Wait Now + TimeValue("00:00:2")
SendKeys "^a"
Application.Wait Now + TimeValue("00:00:2")
SendKeys "^c"
Application.Wait Now + TimeValue("00:00:1")
AppActivate ActiveWorkbook.Windows(1).Caption
objPDF.GetFromClipboard
textPDF = objPDF.GetText(1)
MsgBox textPDF
If you're interested see my project in github.

Copying and pasting by user interactions emulation could be not reliable (for example, popup appears and it switches the focus). You may be interested in trying the commercial ByteScout PDF Extractor SDK that is specifically designed to extract data from PDF and it works from VBA. It is also capable of extracting data from invoices and tables as CSV using VB code.
Here is the VBA code for Excel to extract text from given locations and save them into cells in the Sheet1:
Private Sub CommandButton1_Click()
' Create TextExtractor object
' Set extractor = CreateObject("Bytescout.PDFExtractor.TextExtractor")
Dim extractor As New Bytescout_PDFExtractor.TextExtractor
extractor.RegistrationName = "demo"
extractor.RegistrationKey = "demo"
' Load sample PDF document
extractor.LoadDocumentFromFile ("c:\sample1.pdf")
' Get page count
pageCount = extractor.GetPageCount()
Dim wb As Workbook
Dim ws As Worksheet
Dim TxtRng As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
For i = 0 To pageCount - 1
RectLeft = 10
RectTop = 10
RectWidth = 100
RectHeight = 100
' check the same text is extracted from returned coordinates
extractor.SetExtractionArea RectLeft, RectTop, RectWidth, RectHeight
' extract text from given area
extractedText = extractor.GetTextFromPage(i)
' insert rows
' Rows(1).Insert shift:=xlShiftDown
' write cell value
Set TxtRng = ws.Range("A" & CStr(i + 2))
TxtRng.Value = extractedText
Next
Set extractor = Nothing
End Sub
Disclosure: I am related to ByteScout

Using Bytescout PDF Extractor SDK is a good option. It is cheap and gives plenty of PDF related functionality. One of the answers above points to the dead page Bytescout on GitHub. I am providing a relevant working sample to extract table from PDF. You may use it to export in any format.
Set extractor = CreateObject("Bytescout.PDFExtractor.StructuredExtractor")
extractor.RegistrationName = "demo"
extractor.RegistrationKey = "demo"
' Load sample PDF document
extractor.LoadDocumentFromFile "../../sample3.pdf"
For ipage = 0 To extractor.GetPageCount() - 1
' starting extraction from page #"
extractor.PrepareStructure ipage
rowCount = extractor.GetRowCount(ipage)
For row = 0 To rowCount - 1
columnCount = extractor.GetColumnCount(ipage, row)
For col = 0 To columnCount-1
WScript.Echo "Cell at page #" +CStr(ipage) + ", row=" & CStr(row) & ", column=" & _
CStr(col) & vbCRLF & extractor.GetCellValue(ipage, row, col)
Next
Next
Next
Many more samples available here: https://github.com/bytescout/pdf-extractor-sdk-samples

To improve the solution of Slinky Sloth I had to add this beforere get from clipboard :
Set objPDF = New MSForms.DataObject
Sadly it didn't worked for a pdf of 10 pages.

This doesn't seem to work with the Adobe Type library. As soon as it gets to Open, I get a 429 error. Acrobat works fine though...

Related

Save used range as jpg to SharePoint online with variable name

I have been trying for a while now to edit different code pieces found online to save only the used range of my active workbook as a jpg to my SharePoint online directory. I managed to make a VBA Code work that saves the range as a jpg in a local path but when I change this path to my SharePoint online link it only opens my file explorer and asks me to SaveAs.
I am very new to VBA so I basically have no experience and would therefore be very thankful for any help. Below the VBA Code that does not work right now.
I am pretty sure that the issue lies within the ExportName= ... and ChO.Chart.Export since I took this part from a code that SavesAs to a local path. But like mentioned before I am very new to VBA and therefore have no idea how to recode this to my use case.
Sub SaveAsJPG()
Dim ChO As ChartObject, ExportName As String
Dim CopyRange As Range
Dim Pic As Picture
Dim i As Long
Dim SharePointAdress As String
'My SharePoint Online Adress
SharePointAdress = "https://xxxxxx.sharepoint.com/sites/xxxxx/Shared Documents" & "/"
With ActiveSheet
Set CopyRange = .UsedRange
If Not CopyRange Is Nothing Then
Application.ScreenUpdating = False
ExportName = Application.GetSaveAsFilename(InitialFileName:=SharePointAdress & .Range("A1") & "_" & .Range("J1"), FileFilter:="JPEG Files (*.jpg), *.jpg")
If Not ExportName = "False" Then
CopyRange.Copy
.Pictures.Paste
Set Pic = .Pictures(.Pictures.Count)
Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
Application.CutCopyMode = False
Do
DoEvents
Pic.Copy
DoEvents
ChO.Chart.Paste
DoEvents
i = i + 1
Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)
ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
ChO.Delete
Pic.Delete
End If
Application.ScreenUpdating = True
End If
End With
End Sub
Range A1 & J1 have the name of the Table & the current calender week inside (so the filename is variable). I do not have the option to connect the SharePoint Link to the network folders.
Thank you for any help for a newbie! :)

Editing an embedded word template and saving it without any changes being made to template

i wrote the following code in VBA. I'm able to save the template onto the disk but the changes made are also made on the template which is then saved. I want to save the template with the information separately onto the disk and close the template without any changes being made to it. Also after I insert the details into header / footer, i used code to close the header / footer pane. That no longer works and now shows an extra page since i have separate header / footer for each page. How can i do this with the embedded word template since this worked if i kept the word template outside
Private Sub M114_Click()
Dim oleObject As Object
Dim wDoc As Object
Set oleObject = ActiveWorkbook.Sheets("Properties").OLEObjects(1)
oleObject.Verb Verb:=xlPrimary
ActiveSheet.Range("A1").Select
Set wDoc = oleObject.Object
' Creates the last row that will be used
'lRow = ThisWorkbook.Sheets("Input").Cells(Rows.Count, 1).End(xlUp).Row
' Loop through all the rows
'For i = 3 To lRow
i = 3
' Control 1/21 - Date of Letter
wDoc.ContentControls(1).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 2)
wDoc.ContentControls(21).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 2)
' Control 2/14 - Bank Contact Name
wDoc.ContentControls(2).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 13)
wDoc.ContentControls(14).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 13)
' Update Headers from page 3 to page 5
For j = 3 To 5
With wDoc.Sections(j).Headers(wdHeaderFooterPrimary).Range
.InsertAfter Text:=vbCrLf & UCase(ThisWorkbook.Sheets("Input").Cells(i, 6))
.InsertAfter vbTab
.InsertAfter Text:=vbCrLf & vbCrLf & UCase(ThisWorkbook.Sheets("Input").Cells(i, 7))
.InsertAfter vbTab
.InsertAfter Text:=vbCrLf & vbCrLf & ("At close of business on 31 December " & DatePart("yyyy", ThisWorkbook.Sheets("Input").Cells(i, 4)))
End With
Next j
'''' Issue with this resolve this
' Close the header / footer pane
wDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
wDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
' Create the file name and save and close the file
file_name = Application.WorksheetFunction.Trim("BankConf-" & ThisWorkbook.Sheets("Input").Cells(i, 6) & "-" & ThisWorkbook.Sheets("Input").Cells(i, 7) & ".doc")
wDoc.SaveAs2 (ThisWorkbook.Path & "/" & file_name)
'wDoc.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
wDoc.Application.Quit
Side comment first: usually one would do what you want with mail merge in word ...
Regarding your question:
First of all - you should add a document (docx) as oleobject not a template (dotx). The template shows a somewhat strange behaviour.
Second it is necessary that you first do the saveAs, then open the new file to a separate doc-variable. By that the original oleObject-doc will not be edited.
Furthermore I would suggest two enhancements that make your code much more readable and more robust:
Insert a table for your data (= listobject in VBA) - then you can address the column-names in the code which is easier to maintain and to read than .cells(i,6).
You then can use these column names as tags for the content controls (ccs) in the word document. It is possible to name two different ccs with the same tag name. There is a method selectContentControlsByTag that returns all ccs with the same tag-name. Even those from headers and footers. So you should according ccs in the headers as well.
(Referencing a cc by index is critical as the index may change if you add a new cc or move them around or add text or ...)
As I understand you only insert some of the values to the letter. Therefore I suggest to postfix these column names e.g. by _cc.
This is the modified code - I added Microsoft Word as a reference to the VBA project.
Option Explicit
Sub createAll()
Dim docSource As Word.Document
Set docSource = getSourceDoc 'from oleObject
'assumption your data are in a table --> insert > table
'column names that have values that should go into the letter are named [CC-Tag]_CC
'example: columns name = DateOfLetter_CC | content controls tag= DateOfLetter
Dim lo As ListObject
Set lo = ThisWorkbook.Sheets("Input").ListObjects(1)
Dim lr As ListRow, lc As ListColumn
Dim docTarget As Word.Document, cc As ContentControl
'loop all rows of data table
For Each lr In lo.ListRows
'get empty word doc for this entry
Set docTarget = getTargetDoc(docSource, getFullFilename(lr))
For Each lc In lo.ListColumns
'within the word doc each CC has an according tag (without postfix)
If Right(lc.Name, 3) = "_CC" Then
For Each cc In docTarget.SelectContentControlsByTag(Split(lc.Name, "_")(0))
'there can be multiple CCs with the same tag
'tags within headers/footers are also handled within this loop
cc.Range.Text = lr.Range.Cells(1, lc.Index)
Next
End If
Next
docTarget.Close True
Next
'close Word
docSource.Application.Quit
MsgBox "ready"
End Sub
Private Function getFullFilename(lr As ListRow) As String
'you have to adjust this to your needs, i.e. add the correct column names to build the filename
Dim lo As ListObject
Set lo = lr.Parent
With lr.Range
getFullFilename = ThisWorkbook.Path & "\" & .Cells(1, lo.ListColumns("BankContactName_CC").Index).Value & ".docx"
End With
End Function
Private Function getSourceDoc() As Word.Document
'retrieves the oleDoc which is later used to save copies from
Dim oleObject As oleObject
Set oleObject = ThisWorkbook.Sheets("Properties").OLEObjects(1)
oleObject.Verb xlVerbOpen
Set getSourceDoc = oleObject.Object
End Function
Private Function getTargetDoc(docSource As Word.Document, FullFilename As String) As Word.Document
'saveas new file - open new file
'this is then returned
docSource.SaveAs2 FullFilename
Dim wrdApp As Word.Application
Set wrdApp = docSource.Application
Set getTargetDoc = wrdApp.Documents.Open(FullFilename)
End Function

Using function to open and update values in external workbooks, but returning source errors

I've been using a function from another StackOverflow question (I'm SO sorry I can't find the original answer!) to help go through a number of cells in Column L that contains a formula that spits our a hyperlinked filepath. It is meant to open each one (workbook), update the values, then save and close the workbook before opening the next one. See below.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
' Update the individual credit models
With ThisWorkbook.Sheets("List")
lr = .Cells(.Rows.Count, "L").End(xlUp).Row
FileNames = .Range("L2:L" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
'do stuff here
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
MsgBox "The Following Files Could Not Be Opened" & _
Chr(10) & msg, 48, "Error"
End If
End Sub
The problem now is I am using this to work on a Network drive, and as a result it cause pathing issues with the Connections/Edit Links part. Each of the files are stored on S:\... which as a result of using the Hyperlink formula, won't be able to find the source data. See below the example image of a file that as been opened through a hyperlink cell from my original workbook. When I go to update the Edit Links section of it, it shows these errors.
If I open that lettered drive in Windows Explorer and find the file, it works with no problems. Open, Update Values > Save > Close, it says unknown...
(but if I click Update values here they update correctly.)
If opened using a Hyperlink formula in a cell (Also directing to S:\..) it says it contains links that cannot be updated. I choose to edit links and they're all "Error: Source not found". The location on them also starts off with \\\corp\... and not S:\.
Anyway to fix this? Apologies for the long winded question.
I'm adding this as an answer as it contains code and is a bit long for a comment.
I'm not sure if it's what you're after though.
The code will take the mapped drive and return the network drive, or visa-versa for Excel files. DriveMap is the variable containing the final string - you may want to adapt into a function.
Sub UpdatePath()
Dim oFSO As Object
Dim oDrv As Object
Dim FileName As String
Dim DriveMap As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileName = Range("A1")
If InStr(oFSO.GetExtensionName(FileName), "xls") > 0 Then
For Each oDrv In oFSO.drives
If oDrv.sharename <> "" Then
'Changes \\corp\.... to S:\
If InStr(FileName, oDrv.sharename) = 1 Then
DriveMap = Replace(FileName, oDrv.sharename, oDrv.Path)
End If
'Changes S:\ to \\corp\....
' If InStr(FileName, oDrv.Path) = 1 Then
' DriveMap = Replace(FileName, oDrv.Path, oDrv.sharename)
' End If
End If
Next oDrv
End If
End Sub

How to export CSV file encoded with "Unicode"

Currently i using VBA code to export range data to a CSV file:
Sub Fct_Export_CSV_Migration() Dim Value As String Dim size As Integer
Value = ThisWorkbook.Path & "\Export_Migration" & Sheets(1).range("B20").Value & ".csv" chemincsv = Value
Worksheets("Correspondance Nv Arborescence").Select Dim Plage As Object, oL As Object, oC As Object, Tmp As String, Sep$ Sep = ";" size = Worksheets("Correspondance Nv Arborescence").range("B" & Rows.Count).End(xlUp).Row Set Plage = ActiveSheet.range("A1:B" & size)
Open chemincsv For Output As #1 For Each oL In Plage.Rows
Tmp = ""
For Each oC In oL.Cells
Tmp = Tmp & CStr(oC.Text) & Sep
Next
'take one less than length of the string number of characters from left, that would eliminate the trailing semicolon
Tmp = Left(Tmp, Len(Tmp) - 1)
Print #1, Tmp Next Close
MsgBox "OK! Export to " & Value End Sub
Now, i would like to export CSV encoded with "Unicode". I think i need to use VBA function like SaveAs( xlUnicodeText ) but how to use that ?
Thx
Unicode CSVs are not one of the file formats supported by Excel, out of the box. This means we cannot use the SaveAs method. The good news we can work around this restriction, using VBA.
My approach uses the file system object. This incredibly handy object is great for interacting with the file system. Before you can use it you will need to add a reference:
From the VBA IDE click Tools.
Click References...
Select Windows Script Host Object Model from the list.
Press OK.
The code:
' Saves the active sheet as a Unicode CSV.
Sub SaveAsUnicodeCSV()
Dim fso As FileSystemObject ' Provides access to the file system.
Dim ts As TextStream ' Writes to your text file.
Dim r As Range ' Used to loop over all used rows.
Dim c As Range ' Used to loop over all used columns.
' Use the file system object to write to the file system.
' WARNING: This code will overwrite any existing file with the same name.
Set fso = New FileSystemObject
Set ts = fso.CreateTextFile("!!YOUR FILE PATH HERE.CSV!!", True, True)
' Read each used row.
For Each r In ActiveSheet.UsedRange.Rows
' Read each used column.
For Each c In r.Cells
' Write content to file.
ts.Write c.Value
If c.Column < r.Columns.Count Then ts.Write ","
Next
' Add a line break, between rows.
If r.Row < ActiveSheet.UsedRange.Count Then ts.Write vbCrLf
Next
' Close the file.
ts.Close
' Release object variables before they leave scope, to reclaim memory and avoid leaks.
Set ts = Nothing
Set fso = Nothing
End Sub
This code loops over each used row in the active worksheet. Within each row, it loops over every column in use. The contents of each cell is appended to your text file. At the end of each row, a line break is added.
To use; simply replace !!YOUR FILE PATH HERE.CSV!! with your file name.

Titles in one CSV, Hyperlinks in other CSV, create new CSV with links built in

I have plain text titles in one .csv and hyperlinks for those titles in another .csv
I currently open them in the same work book, put the titles in A, the hyperlinks in H, and use
=HYPERLINK(H1,A1)
to get my final output of Titles with hyperlinks built in.
Is there an easy way (Excel VBA or macro) to bypass the manual work and create a new output file with the "Titles with hyperlinks built in" from the original two .csv files?
Edit: My two .csv files have the respective text (hyperlink and titles) all down column A.
Sub buildlinks()
Dim i As Integer
Dim wb1, wb2 As Workbook
Set wb1 = Application.Workbooks.Open("C:/path/Links.csv")
Set wb2 = Application.Workbooks.Open("C:/path/Titles.csv")
i = 1
Do Until wb1.Sheets("Sheet1Name").Cells(i, 1).Value = ""
ThisWorkbook.Sheets("Sheet1Name").Cells(i, 1).Formula = "=HYPERLINK(" & wb1.Sheets("Sheet1Name").Cells(i, 1).Value & "," & wb2.Sheets("Sheet1Name").Cells(i, 1).Value & ")"
i = i + 1
Loop
End Sub
Assuming you want to create the hyperlinks in the current spreadsheet instead of creating a separate file.
Since you've said that the inputs are really just text files, one item per line, not comma-separated, it's actually pretty simple to implement using the VBA file handling commands.
Sub BuildLinks(titlesFilePath as String, linksFilePath As String, ByVal rowStart As Long)
Dim tf As Long, lf As Long, of As Long
tf = FreeFile
On Error Goto NO_TITLE_FILE
Open titlesFilePath For Input As #tf
lf = FreeFile
On Error Goto NO_LINKS_FILE
Open linksFilePath For Input As #lf
On Error Goto 0
While Not (EOF(tf) Or EOF(lf))
Dim curTitle As String, curLink As String
Line Input #tf, curTitle
Line Input #lf, curLink
Cells(rowStart, 1).Formula = "=HYPERLINK(""" & curLink & """,""" & curTitle & """)"
Wend
Close #tf
Close #lf
Exit Sub
NO_TITLE_FILE:
MsgBox "Can't Open Title File" & titlesFilePath
Exit Sub
NO_LINKS_FILE:
MsgBox "Can't Open Links File" & linksFilePath
End Sub

Resources