Text ersetzen (Ersetzen Sie href durch einen Hyperlink)

Question

Es gibt ein Programm, das gut funktioniert. Das Ergebnis ihrer Arbeit ist die Ausgabe in Excel der Tabelle der Elemente (href) (jedes Element sieht wie aus: about: new_ftour.php? Champ = 2604 & f_team = 412 & Tour = 110). Ich möchte href durch einen Hyperlink ersetzen (ersetzen Sie den Text "about:" durch ""). Nach einer Zeile (oRange.Value = data) habe ich eine Zeile hinzugefügt (oRange.Replace What: = "about:", Ersetzung: = "http://allscores.ru/soccer/"). Aber aus mysteriösen Gründen gibt das Programm einen Fehler aus (Laufzeitfehler '91'). In der Zeile (Schleife, während nicht r ist nichts und r.Address <> firstAddress und iLoop < 19).

Sub Softгиперссылки() 
     Application.DisplayAlerts = False 


    Call mainмассивы 

     Application.DisplayAlerts = True 
    End Sub 


    Sub mainмассивы() 
    Dim r As Range 
    Dim firstAddress As String 
    Dim iLoop As Long 
    Dim book1 As Workbook 
    Dim sheetNames(1 To 19) As String 
    Dim Ssilka As String 


    sheetNames(1) = "Лист1" 
    sheetNames(2) = "Лист2" 
    sheetNames(3) = "Лист3" 
    sheetNames(4) = "Лист4" 
    sheetNames(5) = "Лист5" 
    sheetNames(6) = "Лист6" 
    sheetNames(7) = "Лист7" 
    sheetNames(8) = "Лист8" 
    sheetNames(9) = "Лист9" 
    sheetNames(10) = "Лист10" 
    sheetNames(11) = "Лист11" 
    sheetNames(12) = "Лист12" 
    sheetNames(13) = "Лист13" 
    sheetNames(14) = "Лист14" 
    sheetNames(15) = "Лист15" 
    sheetNames(16) = "Лист16" 
    sheetNames(17) = "Лист17" 
    sheetNames(18) = "Лист18" 
    sheetNames(19) = "Лист19" 

    'пропускаем ошибку 

    Set book1 = Workbooks.Open("E:\Super M\Проект ставки\Поиск решения\Усов 7\Условия для андердогов\пробная.xlsm") 


    iLoop = 0 

    With book1.Worksheets("Лист1").Range("S34:S99") '<--| open wanted workbook and refer to cells "U33:U99" in its worksheet "7" 

    Set r = .Find(What:="1", LookIn:=xlValues) '<--| the Find() method is called on the range referred to in the preceding With statement 
    If Not r Is Nothing Then 
     firstAddress = r.Address 
     Do 
      iLoop = iLoop + 1 
      Ssilka = r.Offset(, -14).Hyperlinks.Item(1).Address 
      .Parent.Parent.Worksheets(sheetNames(1)).Activate 
      .Parent.Parent.Save 
      extractTable Ssilka, book1, iLoop 

      Set r = .FindNext(r) '<--| the FindNext() method is still called on the same range as in the preceding .Find() statement 
     Loop While Not r Is Nothing And r.Address <> firstAddress And iLoop < 19 '<--| exit loop if either you hit the first link or completed three loops 
    End If 
    End With 
    book1.Save 
    book1.Close 



    Exit Sub 


    End Sub 


    Function extractTable(Ssilka As String, book1 As Workbook, iLoop As Long) 
    Dim oDom As Object, oTable As Object, oRow As Object 
    Dim iRows As Integer, iCols As Integer 
    Dim x As Integer, y As Integer 
    Dim data() 
    Dim oHttp As Object 
    Dim oRegEx As Object 
    Dim sResponse As String 
    Dim oRange As Range 



    ' get page 
    Set oHttp = CreateObject("MSXML2.XMLHTTP") 
    oHttp.Open "GET", Ssilka, False 
    oHttp.Send 

    ' cleanup response 
    sResponse = StrConv(oHttp.responseBody, vbUnicode) 
    Set oHttp = Nothing 

    sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE ")) 

    Set oRegEx = CreateObject("vbscript.regexp") 
    With oRegEx 
    .MultiLine = True 
    .Global = True 
    .IgnoreCase = False 
    .Pattern = "<(script|SCRIPT)[\w\W]+?</\1>" 
    sResponse = .Replace(sResponse, "") 
    End With 
    Set oRegEx = Nothing 

    ' create Document from response 
    Set oDom = CreateObject("htmlFile") 
    oDom.Write sResponse 
    DoEvents 

    ' table with results, indexes starts with zero 
    Set oTable = oDom.getelementsbytagname("table")(3) 

    DoEvents 

    iRows = oTable.Rows.Length 
    iCols = oTable.Rows(1).Cells.Length 

    ' first row and first column contain no intresting data 
    ReDim data(1 To iRows - 1, 1 To iCols - 1) 

    ' fill in data array 
    For x = 1 To iRows - 1 
    Set oRow = oTable.Rows(x) 

    For y = 1 To iCols - 1 
     If oRow.Cells(y).Children.Length > 0 Then 
      data(x, y) = oRow.Cells(y).getelementsbytagname("a")(0).getattribute("href") 

      '.Replace(data(x, y), "about:", "http://allscores.ru/soccer/") 

     End If 

     Next y 
    Next x 

    Set oRow = Nothing 
    Set oTable = Nothing 
    Set oDom = Nothing 


    ' put data array on worksheet 

    Set oRange = book1.ActiveSheet.Cells(34, iLoop * 25).Resize(iRows - 1, iCols - 1) 
    oRange.NumberFormat = "@" 
    oRange.Value = data 

    oRange.Replace What:="about:", Replacement:="http://allscores.ru/soccer/" 


    Set oRange = Nothing 

    'Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _ 
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ 
     ReplaceFormat:=False, MatchByte:=False 


    '<DEBUG> 
    ' For x = LBound(data) To UBound(data) 
    '  Debug.Print x & ":[ "; 
    '  For y = LBound(data, 2) To UBound(data, 2) 
    '   Debug.Print y & ":[" & data(x, y) & "] "; 
    '  Next y 
    '  Debug.Print "]" 
    ' Next x 
    '</DEBUG> 



    End Function 

Answer 1

Wie @ YowE3K in den Kommentaren erwähnt, wenn r is Nothing, würde weiterhin die VBA-Engine die IF-Anweisung zu bewerten und auf r.Address scheitern würde.

Andere Sprachen verhalten sich anders, und würde die Prüfung so schnell entkommen, da sie eine falsche Bedingung finden, aber VBA ist es auf diese Weise nicht tun - Does the VBA "And" operator evaluate the second argument when the first is false?

Dies ist ein - Diese Auswertung Kurzschluss genannt wird Art und Weise um:

Option Explicit 

Public Sub TestMe() 

    Dim iloop   As Long 
    Dim r    As Range 
    Dim firstAddress As String 

    Do While True 

     If r Is Nothing Then Exit Do 
     If r.Address = firstAddress Then Exit Do 
     If iloop < 10 Then Exit Do 

     'Do the action 

    Loop 

End Sub