Sub RecherecheLien() ' déclaration des variables Dim ObjectIE As Object, MonUrl As String Dim MesElements As Object, i As Long, j As Long MonUrl = "http://www.vbfrance.com" Set ObjectIE = CreateObject("InternetExplorer.Application") 'ObjectIE.Visible = True ObjectIE.navigate (MonUrl) Do Until ObjectIE.READYSTATE = 4: DoEvents: Loop Do While ObjectIE.Busy: DoEvents: Loop DoEvents Set MesElements = ObjectIE.Document.getElementsByTagName("a") ' "a" represente une collection d'objets "Element" j = 1 For i = 0 To MesElements.Length - 1 'si l'innertext de l’élément contient le mot "codes" If LCase$(MesElements(i).getAttribute("innertext")) Like "*codes*" Then 'on récupère le lien Range("A" & j).Value = (MesElements(i).getAttribute("href")) 'ici "href" renvoi l'url recherchée. "href" est une propriété de "a" j = j + 1 End If Next ObjectIE.Quit Set ObjectIE = Nothing End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionPublic Sub Gethtml() Dim dest, xlsfile, myURL, Period As String Dim IE As Object, objDoc As Object Dim filecode, LastRowA, i, n, j As Integer Dim txt Dim tabtemp(1000) 'Clean the sheet Range("A5:B300").ClearContents Application.DisplayAlerts = False xlsfile = ActiveWorkbook.Name myURL = Range("B1").Value Period = Range("B3").Value i = 1 Sheets("Macro").Select Application.DisplayAlerts = True Set IE = CreateObject("internetexplorer.application") IE.navigate myURL 'Waiting IE is ready Do If IE.readyState = 4 Then IE.Visible = False Exit Do Else DoEvents End If Loop Set objDoc = IE.document 'Path of temporary file dest = Range("B2").Value dest = dest & "\temp.txt" Set fsys = CreateObject("Scripting.FileSystemObject") ' Check if the file already exists If fsys.FileExists(dest) = False Then Set txt = fsys.CreateTextFile(dest) Set txt = Nothing End If nFile = FreeFile nFile2 = FreeFile ' Write the source code of the URL in the temporary file Open dest For Output Shared As #nFile Print #nFile, objDoc.DocumentElement.innerHTML Close #nFile ' Check every line and copy the path to the next line Open dest For Input As #nFile2 While Not EOF(nFile2) Line Input #nFile2, txtline If txtline Like "*xls*" And txtline Like ("*" & Period & "*") And txtline Like "*href*" Then tabtemp(i) = InStr(txtline, "href") tabtemp(i) = Mid(txtline, tabtemp(i) + 6) txtline = tabtemp(i) If txtline Like "*xlsm*" Then tabtemp(i) = InStr(txtline, "xlsm") tabtemp(i) = Left(txtline, tabtemp(i) + 3) ElseIf txtline Like "*xlsx*" Then tabtemp(i) = InStr(txtline, "xlsx") tabtemp(i) = Left(txtline, tabtemp(i) + 3) ElseIf txtline Like "*xls*" Then tabtemp(i) = InStr(txtline, "xls") tabtemp(i) = Left(txtline, tabtemp(i) + 2) End If i = i + 1 n = i End If Wend Close #nFile2 j = 5 'Check for double lines For i = 1 To n If tabtemp(i) <> tabtemp(i - 1) Then Sheets("Macro").Range("A" & j).Value = tabtemp(i) j = j + 1 End If Next Kill dest Windows(xlsfile).Activate IE.Application.Quit Set objDoc = Nothing Set IE = Nothing End Sub