宏將只在調試模式下創建超鏈接

這是一個宏，它將搜索單個目錄中包含的所有工作簿中所有工作表中的所有單元格。除了添加超鏈接方法外，一切都可以像廣告中那樣工作，如果我反覆碾碎F8，則可以工作。宏將只在調試模式下創建超鏈接

如何編輯宏使超鏈接部分起作用？

'Search all workbooks in a folder for string 
Sub SearchWorkbooks() 
Dim fso As Object 
Dim fld As Object 
Dim strSearch As String 
Dim strPath As String 
Dim strFile As String 
Dim wOut As Worksheet 
Dim wbk As Workbook 
Dim wks As Worksheet 
Dim Lrow As Long 
Dim rFound As Range 
Dim strFirstAddress As String 

On Error GoTo ErrHandler 
Application.ScreenUpdating = False 

strSearch = "Capacitor" 
strPath = "C:\!Source" 

Set wOut = Worksheets.Add 
Lrow = 1 
With wOut 
    .Name = "Results" 
    .Cells(Lrow, 1) = "Workbook" 
    .Cells(Lrow, 2) = "Worksheet" 
    .Cells(Lrow, 3) = "Cell" 
    .Cells(Lrow, 4) = "Text in Cell" 
    .Cells(Lrow, 5) = "Link" 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set fld = fso.GetFolder(strPath) 

    strFile = Dir(strPath & "\*.xls*") 
    Do While strFile <> "" 
     Set wbk = Workbooks.Open _ 
      (Filename:=strPath & "\" & strFile, _ 
      UpdateLinks:=0, _ 
      ReadOnly:=True, _ 
      AddToMRU:=False) 

     For Each wks In wbk.Worksheets 
      Set rFound = wks.UsedRange.Find(strSearch) 
      If Not rFound Is Nothing Then 
       strFirstAddress = rFound.Address 
      End If 
      Do 
       If rFound Is Nothing Then 
        Exit Do 
       Else 
        Lrow = Lrow + 1 
        .Cells(Lrow, 1) = wbk.Name 
        .Cells(Lrow, 2) = wks.Name 
        .Cells(Lrow, 3) = rFound.Address 
        .Cells(Lrow, 4) = rFound.Value 

        'This is the line that does not work 
        'well it actually works in debug mode but not in real time 
        wks.Hyperlinks.Add Anchor:=Cells(Lrow, 5), Address:=wbk.FullName, SubAddress:= _ 
            wks.Name & "!" & rFound.Address, TextToDisplay:="Link" 

       End If 
       Set rFound = wks.Cells.FindNext(After:=rFound) 
      Loop While strFirstAddress <> rFound.Address 
     Next 

     wbk.Close (False) 
     strFile = Dir 
    Loop 
    .Columns("A:D").EntireColumn.AutoFit 
End With 
'MsgBox "Done"  

ExitHandler: 
Set wOut = Nothing 
Set wks = Nothing 
Set wbk = Nothing 
Set fld = Nothing 
Set fso = Nothing 
Application.ScreenUpdating = True 
Exit Sub 

ErrHandler: 
MsgBox Err.Description, vbExclamation 
Resume ExitHandler 
End Sub

來源

2015-04-28 bolilloBorracho

這聽起來像一個計時相關的問題（這是沒有意義的），嘗試註釋掉了'Application.ScreenUpdating = FALSE'線運行它。這可能會減緩它的運作。 – FreeMan

謝謝，但不幸的是它沒有工作。這絕對是一個時間問題，因爲當慢慢開車時，它是完美的。 – bolilloBorracho

當您使用多個工作表時，不應該對工作表使用隱式引用。嘗試將工作表引用添加到像'wks.Cells（......）'''Cells'（）''' – 314UnreadEmails

嘗試添加工作表引用您的通話Cells()出像wks.Cells(......)

來源

2015-04-29 21:28:37 314UnreadEmails

這就是它！不僅如此，它還修復了有時會寫錯錯誤的工作簿的煩惱。非常感謝！ – bolilloBorracho

宏將只在調試模式下創建超鏈接

回答

相關問題