excel - 进入新的私有(private)子目录时生成的超链接消失

Question

在附加的代码中，我正在搜索关键字，然后创建一个包含文件名、工作表、单元格、数据等行条目的新工作表。我试图将超链接(感谢 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

Answer 1

如评论中所述，限定您的 Range 语句，以便它不会将超链接放入您随后关闭而不保存的工作簿中。

即改变

Range("C" & xRow).Formula = "=HYPERLINK(" & Chr(34) & "[" & _

至

.Range("C" & xRow).Formula = "=HYPERLINK(" & Chr(34) & "[" & _

<小时/>

从代码中获取相关行:

'******************************************
'*** Set xOut so that it refers to wsReport
Set xOut = wsReport
'******************************************

xRow = 1

'******************************************
'*** Begin a With block so that "." means "xOut."
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 <> ""

'******************************************
'*** Open a workbook, and make it the ActiveWorkbook and one of its sheets
'*** the ActiveSheet
        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

'******************************************
'*** Write information to column A of the report
                    .Cells(xRow, 1) = xWb.Name
'******************************************

'******************************************
'*** Write information to column B of the report
                    .Cells(xRow, 2) = xWk.Name
'******************************************

'******************************************
'*** Write information to column C of the report
                    .Cells(xRow, 3) = xFound.Address
'******************************************

'******************************************
'*** Write information to column C of the ActiveWorkbook's ActiveSheet
'*** (because "Range" is unqualified)
'*** If this was ".Range" it would write information to column C of the report
                    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

'******************************************
'*** Close the ActiveWorkbook (which has had hyperlinks added to it)
'*** without saving
        xWb.Close (False)
'******************************************

<小时/>

我告诉您限定范围的“官方”(可能是“可信”)来源可以在 MSDN documentation 中找到。对于 Range 对象，它(部分)表示:

When it’s used without an object qualifier (an object to the left of the period), the Range property returns a range on the active sheet.