替换文本（用超链接替换 ​​href）

Question

有一个程序运行良好。 她的工作结果是元素表 (href) 的 Excel 输出（每个元素看起来像：about:new_ftour.php?champ=2604&f_team=412&tour=110）。 我想用超链接替换 ​​href（将文本“about:”替换为“ http://allscores.ru/soccer/ ”）。 在一行 (oRange.Value=data) 之后我添加了一行 (oRange.Replace What:="about:", Replacement:="http://allscores.ru/soccer/")。 但是出于神秘的原因，程序给出了错误 (Run-time error '91') 。 在行中（Loop While Not r Is Nothing And r.Address <> firstAddress And 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

正如@YowE3K 的评论中所提到的，如果r is Nothing ，则 VBA 引擎将继续评估 IF 语句，并且会在r.Address上r.Address 。

其他语言的行为不同，一旦发现错误条件就会逃避检查，但 VBA 不会这样做 - 这称为短路评估- VBA“And”运算符是否在第一个参数时评估第二个参数是假的？

这是一种解决方法：

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