2017-10-11 126 views
1

有一個程序工作正常。她的工作結果是元素表(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/」)。但出於神祕的原因,程序會給出一個錯誤(運行時錯誤'91')。在線(Loop While Not r Is Nothing and r.Address <> firstAddress And iLoop < 19)。替換文本(用超鏈接替換href)

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 
+0

環路雖然不屬於R一無所有,r.Address聲明'<> firstAddress而ILOOP <19',如果'r'是'Nothing'代碼會崩潰試圖獲取其'。地址'屬性。 (但幸運的是,它絕對不應該成爲該行的'Nothing')。 – YowE3K

回答

2

正如@ YowE3K在評論中提到的,如果r is Nothing,VBA引擎將繼續評估IF語句,並會失敗的r.Address

其他語言不同的行爲,併爲他們找到一個假條件將盡快逃避檢查,但VBA不會做這種方式 - 這就是所謂的短路評價 - Does the VBA "And" operator evaluate the second argument when the first is false?

這是一個辦法解決:

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 
+1

我當時認爲'r'永遠不會成爲'Nothing',因爲如果原來的'Find'找到了某個東西,它就只能進入循環,而且因此FindNext也會找到一些東西(即使這是原始值)。但是,我猜如果要搜索的單元格包含公式,並且這些公式將根據對圖紙的更改重新計算,那麼可能不再計算搜索的「1」。所以這可能是**問題。 – YowE3K

+1

P.S.我認爲你需要稍微改變邏輯流程,以便在r.Address **等於** firstAddress(即如果FindNext返回到原始查找)時退出。 – YowE3K

+0

@ YowE3K - 真的,謝謝,改變了。 – Vityata