Dim MyFiles As New Collection
'C:\Users\root\Dropbox\Excel Stuff\Cym Prints
Sub BOM_Hyperlinks_Setup()
If MsgBox("Hello. Please make sure you have a backup of this workbook before proceeding." & vbCrLf & _
"Actions taken by this program cannot be undone." & vbCrLf & "Do you wish to continue?", vbYesNo) _
= vbNo Then Exit Sub _
Else: continueprocedure = True
ResumePath:
On Error GoTo ErrorHandle
FolderPath = InputBox("Please enter the path of the folder you wish to search: ")
Set PathCheck = CreateObject("Scripting.FileSystemObject")
Set folder = PathCheck.getfolder(FolderPath)
ResumeColumn:
On Error GoTo ErrorHandle
PartNoColumn = InputBox("Enter the column that the part numbers are in: ")
Range(PartNoColumn & "1").Select
ResumeFirstPart:
On Error GoTo ErrorhandleRow
FirstPart = InputBox("Enter the row that the first part number is in: ")
Range(PartNoColumn & FirstPart).Select
On Error GoTo 0
Add_Links FolderPath, PartNoColumn, FirstPart
Application.ScreenUpdating = True
MsgBox ("All done!")
Exit Sub
ErrorHandle:
Debug.Print Err.Number
Select Case Err.Number
Case 76
If MsgBox("That is not a valid file path." & vbCrLf & "Try again?", vbYesNo) _
= vbNo Then Exit Sub Else _
Resume ResumePath
Case 5
If MsgBox("Sorry, without a folder I cannot continue." & vbCrLf & _
"Try again?", vbYesNo) _
= vbNo Then Exit Sub Else _
Resume ResumePath
Case 1004
If MsgBox("That is not a valid column." & vbCrLf & _
"Try again?", vbYesNo) _
= vbNo Then Exit Sub Else _
Resume ResumeColumn
End Select
ErrorhandleRow:
Debug.Print Err.Number
Select Case Err.Number
Case 1004
If MsgBox("That is not a valid row." & vbCrLf & _
"Try again?", vbYesNo) _
= vbNo Then Exit Sub Else _
Resume ResumeFirstPart
End Select
MsgBox ("Something unexpected has happened. This program will end." & vbCrLf & _
"Please write down this error number for debugging and program improvement." & vbCrLf & _
"The error number is " & Err.Number)
End Sub
Sub Add_Links(FolderPath, PartNoColumn, FirstPart)
Application.ScreenUpdating = False
'Columns(Columns(PartNoColumn.Count) + 1).Insert
Debug.Print PartNoColumn
'Range(PartNoColumn).Offset(0.1).Insert
Range(PartNoColumn & ":" & PartNoColumn).Offset(0, 1).Insert
Dim CellRange As String
CellRange = PartNoColumn & FirstPart & ":" & PartNoColumn & ActiveSheet.UsedRange.Rows.Count
'Range("B1:C5").Clear
Dim rngPartList As Range, rngPartNo As Range
Dim i As Long, j As Long
Set rngPartList = ActiveSheet.Range(CellRange)
FileList FolderPath, 0
For Each rngPartNo In rngPartList
If rngPartNo.Value = "" Then GoTo BlankCell
Debug.Print rngPartNo
j = 0
For i = 1 To MyFiles.Count
If InStr(1, MyFiles.Item(i)(1), rngPartNo, vbTextCompare) > 0 Then
If rngPartNo.Cells.Offset(j, 1).Value <> "" Then j = j + 1
If j > 0 Then Rows(rngPartNo.Row + j).Insert
Debug.Print rngPartNo.Row
Debug.Print rngPartNo
ActiveSheet.Hyperlinks.Add Anchor:=rngPartNo.Offset(j, 1), Address:=MyFiles.Item(i)(0), TextToDisplay:=MyFiles.Item(i)(1)
End If
Next i
BlankCell:
Next rngPartNo
Set MyFiles = Nothing
Columns(PartNoColumn & ":" & PartNoColumn).Offset(0, 1).AutoFit
End Sub
Sub FileList(MyPath, counter)
Dim fso, folder, SubFolders, subfolder, file
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)
If counter = 0 Then
For Each file In folder.files
MyFiles.Add Array(file, file.Name)
Next file
End If
Set SubFolders = folder.SubFolders
For Each subfolder In SubFolders
For Each file In subfolder.files
MyFiles.Add Array(file, file.Name)
Next file
FileList subfolder, 1
Next
End Sub
ffset(0, j), Address:=MyFiles.Item(i)(0), TextToDisplay:=MyFiles.Item(i)(1)
