Question

在附带的代码中，我循环浏览文件夹中的所有Excel文件并搜索关键字。然后，我提取文件名，工作表编号，单元格编号和行数据，并将该信息放入名为“摘要”的新创建的电子表格中。如何仅将工作表＃和单元格＃列（列B和C）超链接以指向新创建的行条目来自的确切文件，页面，单元格？

以下是我的代码片段：

 Sub SearchFolders()
'UpdatebySUPERtoolsforExcel2016
 ...
    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 xCount As Long
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a forlder"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
  ...
    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"
        ...
        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

                    xCount = xCount + 1
                    xRow = xRow + 1
                    .Cells(xRow, 1) = xWb.Name
                    .Cells(xRow, 2) = xWk.Name
                    .Cells(xRow, 3) = xFound.Address
                     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
    ...
    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
  xReceiver.Offset(, 1).Value = xDonor.Address

  xDonor.EntireRow.Resize(, 100).Copy xReceiver.Offset(, 2)

  Set xReceiver = xReceiver.Offset(1)

End Sub

Answer 1

要创建指向external workbook/worksheet/cell的超链接，您需要了解链接的形式

参见此示例

假设您在Joe.Xlsx中有一个文件C:\。我们假设它有一个名为Sheet1的工作表，并且您希望超链接到该工作表的单元格A1。

因此，在您当前的工作簿中，您将键入

=HYPERLINK("[C:\Joe.xlsx]Sheet1!A1","CLICK HERE")

所以，如果你打破它，它将会是这样的。

Dim FileName As String
Dim SheetName As String
Dim CellAddress As String

FileName = "C:\Joe.xlsx"
SheetName = "Sheet1"
CellAddress = "A1"

If InStr(1, SheetName, " ") Then SheetName = "'" & SheetName & "'"

Range("A1").Formula = "=HYPERLINK(" & Chr(34) & "[" & _
                      FileName & _
                      "]" & _
                      SheetName & _
                      "!" & _
                      CellAddress & _
                      Chr(34) & "," & Chr(34) & _
                      "CLICK HERE" & Chr(34) & ")"

只需在循环中的代码中使用它并创建超链接

在Excel工作表中为每个条目创建超链接，但只在特定列中创建

1 个答案: