So, I have a bunch of part numbers and am trying to automate the creation of hyperlinks to PDFs on one of the drives. Of course this drive has main and sub folders to search through for this. Below is the file check code to make sure the pdf is there and properly formatted however, i am having trouble getting it to make another column with the hyperlinks or even just the path address, as we can make this into a hyperlink with normal functions pretty easily.
[Edit] I cannot post pictures yet however, the input is from Column B starting at row 2.
I have gotten it to display the part number again by deleting some of the array writing however, i still cannot get just the path address to show up. In addition, if anyone could help me get the debug.print to save to text file working that would be awesome. It gives me a syntax error when trying to define the debug as a string. Any help would be greatly appreciated as i am new to VBA but, have some C+ experience to go off of.
Sub checkFiles()
Const FolderPath As String = "P:\K-XXXX"
Const FileExt As String = "PDF" ' Not case-sensitive i.e. 'DXF = dxf'
Const fFound As String = "Yes"
Const fNotFound As String = "Error"
Const srcName As String = "Sheet1"
Const srcFirst As String = "B2"
Const dstName As String = "Sheet1"
Const dstFirst As String = "C2"
Dim wb As Workbook
Set wb = ThisWorkbook
Dim rng As Range ' (Source and Destination) Data Range
Dim Data As Variant ' (Source and Destination) Data Array
Dim fData() As String ' File Data Array
Dim mData As Variant ' Match Data Array
Dim n As Long ' File Data and (Match) Data Array Elements Counter
' Write values from Source Range to Data Array.
Set rng = defineColumnRange(defineRange(wb.Worksheets(srcName), srcFirst))
Data = getColumn(rng)
'Debug.Print "Source Data:" & vbLf & Join(Application.Transpose(Data), vbLf)
' Write file paths to File Data Array.
fData = getFilePaths(FolderPath, "*." & FileExt)
Debug.Print "File Data - File Paths:" & vbLf & Join(fData, vbLf)
Dim s As String
Dim y As Integer
y = FreeFile()
Open "U:\Product Tracking\test.txt" For Output As #y
s = Debug.Print "File Data - File Paths:" & vbLf & Join(fData, vbLf)
Print #y, s ' write to file
Close #y
' Replace file paths with file names without file extension.
For n = LBound(fData) To UBound(fData)
fData(n) = FileFromPath(fData(n), True) ' 'True' means no extension.
Next n
Debug.Print "File Data - File Names:" & vbLf & Join(fData, vbLf)
' Dim s As String
' Dim y As Integer
'
' y = FreeFile()
' Open "U:\Product Tracking\test.txt" For Output As #y
'
' s = Debug.Print "File Data - File Names:" & vbLf & Join(fData, vbLf)
' Debug.Print s ' write to immediate
' Print #y, s ' write to file
'
' Close #y
' Write 'matches' to Match Data Array.
mData = Application.Match(Data, fData, 0)
'Debug.Print "Match Data:"
'For n = 1 To UBound(mData)
' Debug.Print mData(n, 1)
'Next
' Overwrite values in Data Array with 'matching results'.
For n = 1 To UBound(Data) ' or 'UBound(mData)'
If IsNumeric(mData(n, 1)) Then
Data(n, 1) = fFound
Else
Data(n, 1) = fNotFound
End If
Next n
'Debug.Print "Destination Data:" & vbLf _
& Join(Application.Transpose(Data), vbLf)
' Write values from Data Array to Destination Range.
With defineRange(wb.Worksheets(dstName), dstFirst)
Dim RowOffset As Long: RowOffset = .Row - rng.Row
Dim ColumnOffset As Long: ColumnOffset = .Column - rng.Column
Set rng = .Worksheet.Range(rng.Offset(RowOffset, ColumnOffset).Address)
End With
rng.Value = Data
End Sub
Function defineRange( _
ws As Worksheet, _
ByVal RangeAddress As String) _
As Range
On Error Resume Next
Set defineRange = ws.Range(RangeAddress)
On Error GoTo 0
End Function
Function defineColumnRange( _
FirstCell As Range) _
As Range
If Not FirstCell Is Nothing Then
With FirstCell
Dim rng As Range
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
Set rng = rng.Find("*", , xlFormulas, , , xlPrevious)
If Not rng Is Nothing Then
Set defineColumnRange = .Resize(rng.Row - .Row + 1)
End If
End With
End If
End Function
Function getColumn( _
rng As Range) _
As Variant
If Not rng Is Nothing Then
If InStr(rng.Address, ":") > 0 Then
getColumn = rng.Value
Else
Dim Data As Variant
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
getColumn = Data
End If
End If
End Function
Function getFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "") _
As Variant
Dim ExecString As String
ExecString = "cmd /c Dir """ & FolderPath & Application.PathSeparator _
& FilePattern & """ /b/s"
getFilePaths = Filter(Split(CreateObject("WScript.Shell") _
.Exec(ExecString).StdOut.ReadAll, vbCrLf), ".") ' 'vbCrLf' is a must.
End Function
Function FileFromPath( _
ByVal FilePath As String, _
Optional ByVal NoExtension As Boolean = False) _
As String
Dim FileName As String
FileName = Right(FilePath, _
Len(FilePath) - InStrRev(FilePath, "\"))
If NoExtension Then
FileName = Left(FileName, InStrRev(FileName, ".") - 1)
End If
FileFromPath = FileName
End Function
Untested but this should be close:
Sub checkFiles()
Const FolderPath As String = "P:\K-XXXX"
Const FileExt As String = "PDF" ' Not case-sensitive i.e. 'DXF = dxf'
Const srcName As String = "Sheet1"
Const srcFirst As String = "B2"
Dim wb As Workbook, ws As Worksheet, c As Range, m, pn As String
Dim rngPN As Range, fData() As String, n As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets(srcName)
Set c = ws.Range(srcFirst)
Set rngPN = ws.Range(c, ws.Cells(ws.Rows.count, c.Column).End(xlUp)) 'part numbers
fData = getFilePaths(FolderPath, "*." & FileExt) 'find all files
'loop over found files, try to match base filename to `rngPN`
' and insert link if found
Application.ScreenUpdating = False
For n = LBound(fData) To UBound(fData)
pn = FileFromPath(fData(n), True) 'no extension.
m = Application.Match(pn, rngPN, 0) 'match?
If Not IsError(m) Then
ws.Hyperlinks.Add anchor:=rngPN.Cells(m).Offset(0, 1), _
Address:=fData(n), _
TextToDisplay:="Link"
End If
Next n
End Sub
Function getFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "") _
As Variant
Dim ExecString As String
ExecString = "cmd /c Dir """ & FolderPath & Application.PathSeparator _
& FilePattern & """ /b/s"
getFilePaths = Filter(Split(CreateObject("WScript.Shell") _
.Exec(ExecString).StdOut.ReadAll, vbcrlf), ".") ' 'vbCrLf' is a must.
End Function
Function FileFromPath(ByVal filePath As String, _
Optional ByVal NoExtension As Boolean = False) As String
Static fso As Object
'FSO has handy methods for this type of work....
If fso Is Nothing Then Set fso = CreateObject("scripting.filesystemobject")
FileFromPath = fso.GetFileName(filePath)
If NoExtension Then FileFromPath = fso.GetBaseName(FileFromPath)
End Function