Remplacer le texte (Remplacer href par un lien hypertexte)

Question

Il existe un programme qui fonctionne correctement. Le résultat de son travail est la sortie dans Excel de la table des éléments (href) (chaque élément ressemble à: about: new_ftour.php? Champ = 2604 & f_team = 412 & tour = 110). Je veux remplacer href par un lien hypertexte (remplacer le texte "about:" par "http://allscores.ru/soccer/"). Après une ligne (oRange.Value = data) j'ai ajouté une ligne (oRange.Replace What: = "about:", Remplacement: = "http://allscores.ru/soccer/"). Mais pour des raisons mystérieuses, le programme donne une erreur (Erreur d'exécution '91'). Dans la ligne (Loop While NotR Is Nothing et r.Address> firstAddress et 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

Comme mentionné dans les commentaires par @ YowE3K, si r is Nothing, le moteur VBA continuerait d'évaluer l'instruction IF et échouerait r.Address.

D'autres langues se comportent différemment, et échapperait à la vérification dès qu'ils trouvent une fausse condition, mais VBA ne fait pas de cette façon - On appelle évaluation court-circuit-Does the VBA "And" operator evaluate the second argument when the first is false?

C'est autour:

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