【发布时间】：2017-06-05 19:42:55
【问题描述】：
在附加的代码中，我正在搜索一个关键字，然后创建一个包含文件名、工作表、单元格、数据等行条目的新工作表。我正在尝试将超链接（感谢Siddharth Rout）放入“单元格”列（即该程序中的“C”列）中找到的关键字。当进入新的Private Sub 时，创建的超链接消失了，这是我从搜索的工作簿中提取行数据的地方，导致新创建的文件不包含任何超链接。你能帮我维护新创建的文件中的超链接吗？谢谢。
代码如下：
Sub SearchFolders()
'UpdatebySUPERtoolsforExcel2016
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xStrSearch = "failed"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Create the report sheet at first position then name it "Summary"
Dim wsReport As Worksheet, rCellwsReport As Range
Set wsReport = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))
wsReport.Name = "Summary"
Set rCellwsReport = wsReport.Cells(2, 2)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = wsReport
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Test"
.Cells(xRow, 5) = "Limit Low"
.Cells(xRow, 6) = "Limit High"
.Cells(xRow, 7) = "Measured"
.Cells(xRow, 8) = "Unit"
.Cells(xRow, 9) = "Status"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "\*.xlsx")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch, LookIn:=xlValues)
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
shName = xWk.Name
If InStr(1, shName, " ") Then shName = "'" & shName & "'"
xCount = xCount + 1
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
Range("C" & xRow).Formula = "=HYPERLINK(" & Chr(34) & "[" & _
xWb.FullName & _
"]" & _
shName & _
"!" & _
xFound.Address & _
Chr(34) & "," & Chr(34) & _
xFound.Address & Chr(34) & ")"
WriteDetails rCellwsReport, xFound
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
Loop While xStrAddress <> xFound.Address
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:I").EntireColumn.AutoFit
.Range("A1:A" & xCount + 1).Rows.EntireRow.AutoFit
End With
MsgBox xCount & "cells have been found", , "SUPERtools for Excel"
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Private Sub WriteDetails(ByRef xReceiver As Range, ByRef xDonor As Range)
xReceiver.Value = xDonor.Parent.Name
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copy the row of the Donor to the receiver starting from column D.
' Since you want to preserve formats, we use the .Copy method
xDonor.EntireRow.Resize(, 100).Copy xReceiver.Offset(, 2)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set xReceiver = xReceiver.Offset(1)
End Sub
【问题讨论】：
-
您可以将超链接保存为常量，在子例程之外，或者您可以让第二个子例程从第一个子例程中运行（嵌套它）。或者，您可以有一个包含所有项目的大型子例程。只是想到了一些想法。
-
@Cyril，你能给我举个最简单方法的例子吗？谢谢！
-
您希望单元格 Summary!C2 包含什么？您首先将其设置为包含“失败”的单元格的地址（使用
.Cells(xRow, 3) = xFound.Address行），然后您立即将其更改为公式（使用Range("C" & xRow).Formula = ...行[并且您之前确实应该有一个.Range]），然后调用您的子程序将其重新设置回包含“失败”的单元格的地址（使用行xReceiver.Offset(, 1).Value = xDonor.Address） -
@YowE3K，根据您的输入进行了修改，删除了
xReceiver.Offset(, 1).Value = xDonor.Address。现在，当我运行代码时，我只显示了前 6 个超链接。在新创建的工作表中的第 8 行之后我没有得到任何信息。 -
这可能是因为您正在将超链接公式写入活动工作表（可能在不同的工作簿中）。你真的应该把
.放在Range之前，除非你试图将超链接放在你正在搜索的工作簿中。 （但是，如果是这样，为什么不保存就关闭工作簿？）