<span class="card__author-name">    
            Дмитрий          
   </span> 

myRegExp.MultiLine = True
myRegExp.Global = True  
myRegExp.IgnoreCase = True  
myRegExp.Pattern = "card__author-name.*?$(^.*?$)^.*?<"

Sub test()
    Dim a()
    With Sheets("Лист1")
        a = .Range("A1:J1").Value
        MsgBox UBound(a)
    End With
End Sub 

Function auth() As String
    ' возвращает идентификатор сессии в случае удачной авторизации,  или пустую строку при ошибке
   On Error Resume Next
    Dim oXMLHTTP As New WinHttpRequest
    With oXMLHTTP
        ' первый запрос - для получения идентификатора сессии
       .Open "GET", "http://krsk.24au.ru/", False
       .setRequestHeader "Host", "krsk.24au.ru"
       .setRequestHeader "Connection", "keep-alive"
       .setRequestHeader "Cache-Control", "max-age=0"
       .setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
       .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/37.0.2062.124 Safari/537.36"
       .setRequestHeader "Referer", "http://krsk.24au.ru/"
       .setRequestHeader "Accept-Encoding", "gzip , deflate, sdch"
       .setRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
       .send
       
        For Each .getResponseHeader("Set-Cookie") In .getAllResponseHeaders()
        cookie$ = cookie$ + .getResponseHeader("Set-Cookie")
        Next
        
       If Not cookie$ Like "*SessionId=*" Then
            MsgBox "Ошибка получения идентификатора сессии", vbCritical, "Обратитесь к разработчику программы"
            Exit Function
        End If

        ' отключаем редирект
       .Option(WinHttpRequestOption_EnableRedirects) = False
        ' второй запрос - для авторизации
       .Open "POST", "http://common.24au.ru/login/", False
        PostData = "ReturnUrl=http://krsk.24au.ru/&UserName=" & Пользователь & "&Password=" & Пароль & "&RememberMe=false"
        
        .setRequestHeader "Host", "common.24au.ru"
        .setRequestHeader "Connection", "keep-alive"
        .setRequestHeader "Content-Length", "88"
        .setRequestHeader "Cache-Control", "max-age=0"
        .setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
        .setRequestHeader "Origin", "http://krsk.24au.ru"
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/37.0.2062.124 Safari/537.36"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", "http://krsk.24au.ru/"
        .setRequestHeader "Accept-Encoding", "gzip , deflate"
        .setRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
        .setRequestHeader "Cookie", cookie$
        .send PostData
        
        For Each .getResponseHeader("Set-Cookie") In .getAllResponseHeaders()
        cookie$ = cookie$ + .getResponseHeader("Set-Cookie")
        Next
        
        Location$ = .getResponseHeader("Location") ' при удачной авторизации сайт перенаправляет на указанную страницу
        MsgBox "Location " & Location
       If Not Location$ Like "*http://krsk.24au.ru/*" Then
            MsgBox "Ошибка авторизации на сайте atsenergo.ru", vbCritical, "Обратитесь к разработчику программы"
            Exit Function
        End If
        
        'Идем на Location
        
        .Open "GET", Location$, False
       .setRequestHeader "Host", "krsk.24au.ru"
       .setRequestHeader "Connection", "keep-alive"
       .setRequestHeader "Cache-Control", "max-age=0"
       .setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
       .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/37.0.2062.124 Safari/537.36"
       .setRequestHeader "Referer", "http://common.24au.ru/login/"
       .setRequestHeader "Accept-Encoding", "gzip , deflate, sdch"
       .setRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
       .setRequestHeader "Cookie", cookie$
       .send

        cookie$ = .getResponseHeader("Set-Cookie")
    auth = cookie$
    htmlau = .responseText
    Open "C:\test.txt" For Output As #1

    Print #1, htmlau

    Close #1
   End With
End Function
 

Set IE = CreateObject("InternetExplorer.Application")
 

Sub Запуск()    
    Dim myRegExp As New RegExp ' создаём экземпляр RegExp'a
    Dim aMatch As Match ' один из совпавших образцов
    Dim colMatches As MatchCollection ' коллекция этих образцов
    Dim testString As String ' тестируемая строка
    Dim ieDoc As MSHTML.HTMLDocument
    Dim objCollectionIf As Object
    Dim d, lr1&, k&, i&, j&, a()
    
    With Workbooks("Конкуренты.xls").Sheets("Лист1")
    lr1 = .Cells(.Rows.Count, "b").End(xlUp).Row
    a = .Range("B3:B" & lr1 + 2).Value
    
    For i = 1 To UBound(a)
        
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = False
    IE.Navigate "http://homes.gilcom.ru/view/" & .Cells(i, 2).Value
    While IE.busy Or (IE.readyState <> 4)
        DoEvents
    Wend
    Set ieDoc = IE.Document
    'Debug.Print ieDoc.body.outerHTML
    'ActiveSheet.Cells(1, 3) = ieDoc.body.outerHTML
    testString = ieDoc.body.outerHTML
myRegExp.MultiLine = False ' текст однострочный
myRegExp.Global = True ' будем проходить всю строку
myRegExp.IgnoreCase = True ' игнорируем регистр символов
myRegExp.Pattern = "card__header.(.*)</h2>"
Set colMatches = myRegExp.Execute(testString) ' запускаем!

For Each aMatch In colMatches ' проходим по всей коллекции

Cells(i, 4) = aMatch.SubMatches(0)
 
Next aMatch

myRegExp.Pattern = "card__address.(.*)</p>"
Set colMatches = myRegExp.Execute(testString) ' запускаем!

For Each aMatch In colMatches ' проходим по всей коллекции

Cells(i, 5) = aMatch.SubMatches(0)
 
Next aMatch

myRegExp.Pattern = "card__cost.(.*)</p>"
Set colMatches = myRegExp.Execute(testString) ' запускаем!

For Each aMatch In colMatches ' проходим по всей коллекции

Cells(i, 6) = aMatch.SubMatches(0)
Cells(i, 6).Replace What:="&nbsp;", Replacement:=" "

Next aMatch
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i, 3), _
                               Address:="http://homes.gilcom.ru/view/" & .Cells(i, 2).Value, _
                               TextToDisplay:="Ссылка на жилком"
Next i
End With
End Sub 

.Activate
    .ShowAllData
    .[a1].AutoFilter Field:=1, Criteria1:="Кухонная техника"
    .[a1].AutoFilter Field:=2, Criteria1:="Хлебопечи"
    .Range(.[a2], .Cells(lr1, "a")).SpecialCells(xlCellTypeVisible).Select
    k = Selection.Count
    a = .Range(.[d2], .Cells(lr1, "d")).SpecialCells(xlCellTypeVisible).Value
    Set d = CreateObject("scripting.dictionary")
    For Each x In a: d.Item(x) = 0&: Next

.Activate
    .ShowAllData
    .[a1].AutoFilter Field:=1, Criteria1:="Кухонная техника"
    .[a1].AutoFilter Field:=2, Criteria1:="Хлебопечи"
    On Error GoTo Errors
    .Range(.[a2], .Cells(lr1, "a")).SpecialCells(xlCellTypeVisible).Select
    k = Selection.Count
    lRow = Selection.Row
    If k > 1 Then
    a = .Range(.[d2], .Cells(lr1, "d")).SpecialCells(xlCellTypeVisible).Value
    Set d = CreateObject("scripting.dictionary")
    For Each x In a: d.Item(x) = 0&: Next
    GoTo Endprimer
    Else
    dat = .Cells(lRow, "d").Value
    d.Add x, dat
    GoTo Endprimer
    End If
Errors:
    k = 0
    d.RemoveAll
Endprimer:
 

Sub nalichie_test()
  Dim a(), b(), i&, k&, m&, n&, lr1&, lr2&
  Dim s() As Double
  With Workbooks("for comparison.xls").Sheets(1)
    'Работаем с файлом в котором есть список товара который есть у нас.
    
    .Activate
    .Range("O5").FormulaLocal = "=СЧЁТЗ(A1:A500)"
    .Range("O5").Copy
    'В ячейку О5 вставляем формулу которая считает количество заполненных строк, получая там самым количество товара,
    '1 строка = 1 товар, копируем в буфер ячейку
    
    With Workbooks("Количество незабитого товара.xls").Sheets("БДМ")
        'Начинаем работать с другим файлом и листом, на котором таблица - в столбике А идут даты,
        'в строке 1 идет перечисление групп товаров (ИБП, Ноутбуки и тд и тп)
        
      lr2 = .Cells(.Rows.Count, "a").End(xlUp).Row
      'Узнаем последнюю заполненную ячейку в столбце А
      a = .Range(.[a1], .Cells(1, 100)).Value
      b = .Range(.[a2], .Cells(lr2, "a")).Value
      'Забираем значения из A в массив "b" и из 1 строки в массив "a"
   
      For i = 1 To UBound(b)
       If .Cells(i + 1, "a").Value = DateValue(Now) Then m = i
      Next
       
      For k = 1 To UBound(a)
       If .Cells(1, k + 1).Value = "ИБП" Then n = k
      Next
        .Activate
        .Cells(m, n).PasteSpecial Paste:=xlPasteValues
      
    End With
    
  End With
End Sub



 

Sub ostatki()
    Columns("J:J").Select   'выделяем колонку J
    Selection.Delete Shift:=xlToLeft   'удаляем, избавляясь от цены в рублях
    
    Sheets("KR1_KR1").Range("J2").FormulaLocal = "=ВПР(D2;[KKRF.xls]KRF_KRF!$D$2:$I$5000;6;ЛОЖЬ)"     'Вставляем формулу в J2
    Const lCol As Long = 10 'Column number for find empty cells
Const lFirstRow As Long = 3 'first row for del
Dim li As Long, lLastRow As Long, lCalc As Long

With Application
.ScreenUpdating = 0: lCalc = .Calculation: .Calculation = xlManual
For li = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To lFirstRow Step -1
If Cells(li, lCol) = "" Then Cells(2, 10).Copy           'копируем ячейку J2 с формулой
ActiveSheet.Paste Destination:=Cells(li, lCol)         'вставляем по всей J 
Next li
.ScreenUpdating = 1: .Calculation = lCalc
End With

End Sub