<a target="_blank" href="/Catalog/TecDoc/Index?idArticle=21450203">

<a target="_blank" href="/Catalog/TecDoc/Index?idArticle=21450203">

'/goods/01335/asam/id45064320" >

href="/Catalog/TecDoc/Index?idArticle=21450203">

<td class='t-ac nowrap'><a target='_blank' href='/goods/akd0069/akyoto/id37525751'><i class='r0'></i><span class='s1'></span></a>

Sub OneHref()
    Dim t$, URL$, i As Long
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        URL = URLEncode(Cells(i, "F"))
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", URL, False
        .send
        Do: DoEvents: Loop Until .readyState = 4
        t = .responseText
        Cells(i, "G") = dann(t)
        If Cells(i, "G") = "" Then
           Cells(i, "G") = "not href"
        End If
    End With
    Next
End Sub
Function dann(t As String)
     Dim RegExp As Object
     Set RegExp = CreateObject("VBScript.RegExp")
     RegExp.IgnoreCase = True
     RegExp.Global = False
     RegExp.MultiLine = True
     RegExp.Pattern = "<a target=""_blank"" href=""(.*?)"">"
     If RegExp.Test(t) Then
        dann = RegExp.Execute(t)(0)
     End If
End Function
Function URLEncode(ByVal txt As String) As String
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        Select Case AscW(l)
            Case Is > 4095: t = "%" & Hex(AscW(l) \ 64 \ 64 + 224) & "%" & Hex(AscW(l) \ 64) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
            Case Is > 127: t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
            Case 32: t = "%20"
            Case Else: t = l
        End Select
        URLEncode = URLEncode & t
    Next
End Function

Sub Avtolev()
    Dim t$, URL$, i As Long, Cl As Collection
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        URL = URLEncode(Cells(i, "F"))
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", URL, False
        .send
        Do: DoEvents: Loop Until .readyState = 4
        t = .responseText
        Set Cl = dann(t)
        For Each c In Cl
            Cells(i, "G") = c
        Next
        If Cells(i, "G") = "" Then
           Cells(i, "G") = "нет картинки"
        End If
    End With
    Next
End Sub