因此，我有一堆零件号，并且正在尝试在其中一个驱动器上自动创建 PDF 的超链接。当然，该驱动器有主文件夹和子文件夹可供搜索。下面是文件检查代码，以确保 pdf 存在且格式正确，但是，我无法让它使用超链接甚至只是路径地址创建另一列，因为我们可以将其变成具有正常功能的超链接很容易。
[编辑]我还不能发布图片，但是输入是从第 2 行开始的 B 列。
我已经通过删除一些数组写入来再次显示零件号，但是，我仍然无法仅显示路径地址。此外，如果有人可以帮助我将 debug.print 保存到文本文件中，那就太好了。当我尝试将调试定义为字符串时，它给了我一个语法错误。任何帮助将不胜感激，因为我是 VBA 新手，但有一些 C+ 经验可以借鉴。
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
未经测试，但这应该接近：
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"
Else
rngPN.Cells(m).Offset(0, 1).Value = "No match"
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