Sub prepareData()
          
     'Перед запуском в редакторе VB в меню Tools\References установить ссылку (включить галку)
     'на библиотеку "Microsoft ActiveX Data Objects ... Library", где ... - номер версии.
     'Можно выбрать любой максимальный (6.0, 2.8, 2.5...) из того, что установлено на компьютере.
      
     Dim rst As New ADODB.Recordset
          
     [Лист1].Activate
          
     With Columns("B:B")
         .WrapText = False
         .MergeCells = False
         On Error Resume Next
         .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
         On Error GoTo 0
         .CurrentRegion.Offset(0, 1).Resize(, 3).Name = "MyRange"
     End With
                  
     rst.Open _
     "SELECT F1, F3 FROM MyRange WHERE F2 = 'Итого по телефону:'" _
     , _
     "Provider=Microsoft.ACE.OLEDB.12.0;" & _
     "Data Source=" & ThisWorkbook.FullName & ";" & _
     "Extended Properties='Excel 12.0;HDR=No'"
                 
     [Лист2!A1].CopyFromRecordset rst
          
End Sub

Sub readhtml()

     Dim oD As Object, cc As Range, cnt&

     Set oD = CreateObject("scripting.dictionary")

     For Each cc In Sheets("Список").[c3:c27].Cells
         oD.Item(Trim(cc.Value)) = 0
     Next
     cnt = oD.Count

     strFilePath = "D:\TMP\3\4\2012_aug_004UTF8.html"

     Set objFSO = CreateObject("Scripting.FileSystemObject")
     Set objTS = objFSO.OpenTextFile(strFilePath, 1)

     Do Until objTS.AtEndOfStream    'пока не кончился файл
         strNextLine = objTS.Readline    'читаем посторочно
         If InStr(strNextLine, "Абонентский номер</td><td") Then
             t = Mid(strNextLine, InStr(strNextLine, "left") + 6, 11)
             For ii = 1 To 6: objTS.SkipLine: Next
             If oD.exists(t) Then
                 oD.Item(t) = Val(Replace(objTS.Readline, ",", "."))
                 cnt = cnt - 1
                 If cnt = 0 Then Exit Do
             End If
         End If
     Loop

     Set objFSO = Nothing
     Set objTS = Nothing
     strNextLine = Empty

     For Each cc In Sheets("Список").[c3:c27].Cells
         cc.Offset(, 1) = oD.Item(Trim(cc.Value))
     Next

End Sub