ReignEternal
New Member
- Joined
- Apr 11, 2021
- Messages
- 41
- Office Version
- 365
- Platform
- Windows
Hello,
I have a situation. I have a file (unfortunately I can't share this file as it is a proprietary file for my company but I can provide the associated VBA I am using) that in select cells based on the Manufacture and Model, it is creating hyperlinks to a folder then referencing the folder name and the sub file name.
I have 2 Public Const
The problem I am facing is these are moving to a per job basis and will no longer be "Constant" in the fact that the two above folder locations will no change for every job. See example 1 and 2
Example job 1
"\\fs1\Public\MASTER\JOB 1\SUBMITTALS\"
"\\fs1\Public\MASTER\JOB 1\Owners Manuals\"
"\\fs1\Public\MASTER\JOB 2\SUBMITTALS\"
"\\fs1\Public\MASTER\JOB 2\Owners Manuals\"
In the above examples, the text in bold is what will be changing
Instead of doing a Public Const, how can I fix this to point to the "Current Folder"?
"\\fs1\Public\MASTER\CURRENT FOLDER\SUBMITTALS\"
"\\fs1\Public\MASTER\CURRENT FOLDER\Owners Manuals\"
I have a situation. I have a file (unfortunately I can't share this file as it is a proprietary file for my company but I can provide the associated VBA I am using) that in select cells based on the Manufacture and Model, it is creating hyperlinks to a folder then referencing the folder name and the sub file name.
I have 2 Public Const
VBA Code:
Public Const dirSpec As String = "\\fs1\Public\MASTER\OPS\SUBMITTALS\"
Public Const dirOM As String = "\\fs1\Public\MASTER\OPS\Owners Manuals\"
The problem I am facing is these are moving to a per job basis and will no longer be "Constant" in the fact that the two above folder locations will no change for every job. See example 1 and 2
Example job 1
"\\fs1\Public\MASTER\JOB 1\SUBMITTALS\"
"\\fs1\Public\MASTER\JOB 1\Owners Manuals\"
"\\fs1\Public\MASTER\JOB 2\SUBMITTALS\"
"\\fs1\Public\MASTER\JOB 2\Owners Manuals\"
In the above examples, the text in bold is what will be changing
Instead of doing a Public Const, how can I fix this to point to the "Current Folder"?
"\\fs1\Public\MASTER\CURRENT FOLDER\SUBMITTALS\"
"\\fs1\Public\MASTER\CURRENT FOLDER\Owners Manuals\"
VBA Code:
Sub fSpec(ByVal Target As Range, ByVal sDir As String, ByVal col As Integer, Optional ByVal bOpen As Boolean, Optional ByVal CopyPath As String)
Dim sFolder As String
Dim sPath As String
Dim sFile(3) As String
Dim sManf As String
Dim sModel As String
Dim r As Integer
'Loop over each range of a non continuous range
For Each rng In Target.Areas
'Loop over each row in rng
For r = 1 To rng.Rows.Count
With rng.Rows(r).EntireRow
If .Cells(1, colQtyCur).Value > 0 Then
'Clear out unwanted characters
sManf = Replace(.Cells(1, colManf).Text, "/", "")
sManf = Replace(sManf, "\", "")
sModel = Replace(.Cells(1, colModel), "/", "")
sModel = Replace(sModel, "\", "")
'See if we have a Manf and Model to work with
If sManf <> "" And UCase(sManf) <> "Master" And sModel <> "" Then
'Create the different possibilities
sFolder = sManf & "\"
sFile(1) = sManf & " - " & sModel & ".pdf"
sFile(2) = sManf & "-" & sModel & ".pdf"
sFile(3) = sManf & " " & sModel & ".pdf"
sPath = ""
'Test to see if one of the files exists
For c = 1 To 3
If FileOrDirExists(sDir & sFolder & sFile(c)) Then
sPath = sDir & sFolder & sFile(c)
sFile(0) = sFile(c)
Exit For
End If
Next c
'If a spec sheet is found
If sPath <> "" Then
'Create Hyperlink
Call fHyperlink(.Cells(1, col + 1), sPath, "Link")
'Mark Yes/No row to yes automaticly if we find a spec sheet
If .Cells(1, col) = "" And (.Cells(1, colQtyCur) > 0) Then .Cells(1, col) = "Yes"
'Open the spec sheet if specified in the call
If bOpen Then ThisWorkbook.FollowHyperlink Address:=sPath, NewWindow:=True
'Copy the spec sheet to a specific path if specified in the call
If CopyPath <> "" And .Cells(1, col) = "Yes" Then
If Not FileOrDirExists(CopyPath & sFile(0)) Then FileCopy sPath, CopyPath & sFile(0)
End If
'Otherwise try to open the manf folder, or at least open the main folder
ElseIf bOpen Then
If FileOrDirExists(sDir & sFolder) Then
ThisWorkbook.FollowHyperlink Address:=sDir & sFolder, NewWindow:=True
ElseIf FileOrDirExists(sDir) Then
Result = MsgBox("The folder '" & sFolder & "' does not exist. " & vbCrLf & "Would you like to create it?", vbYesNo, "Create Folder?")
If Result = vbYes Then
On Error Resume Next
MkDir (sDir & sFolder)
On Error GoTo 0
ThisWorkbook.FollowHyperlink Address:=sDir & sFolder, NewWindow:=True
End If
Else
MsgBox "The directory, " & sDir & ", does not exist.", vbCritical, "Directory does not exist!"
End If
End If
End If
End If
End With
If col = colSpec Then
Application.StatusBar = "Specs: " & rng.Rows(r).Row - startline & " of " & rng.Rows.Count - startline
ElseIf col = colOM Then
Application.StatusBar = "O&&M: " & rng.Rows(r).Row - startline & " of " & rng.Rows.Count - startline
End If
DoEvents
Next r
Next rng
Application.StatusBar = False
End Sub