Question

在附加的代码中，我正在搜索关键字，然后创建一个包含文件名，工作表，单元格，数据等行条目的新工作表。我试图在＆＃34; cell＆＃34;中添加一个超链接（感谢Siddharth Rout）到找到的关键字。列（即列＃34; C＆＃34;在此程序中）。当进入新的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)
'******************************************

Range Range对{ ..., imageurl: String, ... }对象的success: function (data) { $.each(data, function (key, elem) { $('#carrusel').append($('<div class="carousel-item item active"><img class="d-block img-fluid" src=' + elem.imageurl + '></div>')); }); //create carousel instance }可以找到“官方”（可能是“可信”）的来源。部分）：

如果在没有对象限定符（句点左侧的对象）的情况下使用它，则Range属性将返回活动工作表上的范围。

输入新的Private Sub时，生成的超链接会消失

1 个答案: