'Dim XMLHttp As Object: Set XMLHttp = CreateObject("Microsoft.XMLHTTP") 
  'Dim XMLHttp As Object: Set XMLHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
  'Dim XMLHttp As Object: Set XMLHttp = CreateObject("MSXML2.ServerXMLHTTP")
  'Dim XMLHttp As Object: Set XMLHttp = CreateObject("MSXML2.XMLHttp") '
  'Dim XMLHttp As Object: Set XMLHttp = New WinHttpRequest
  XMLHttp.Open "GET", "site.com", False 'OR "POST" type and True for redirect
  'XMLHttp.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
  'XMLHttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  'XMLHttp.SetRequestHeader "Cache-Control", "no-store, no-cache"
  'XMLHttp.SetRequestHeader "Pragma", "no-cache"
  'XMLHttp.Send StrConv("title=Title&cat=Cat&post=PostText&pas=tipapass", vbFromUnicode)
  XMLHttp.Send '"title=Title&cat=Cat&post=PostText&pas=tipapass" << тут дольше всего висит
  Debug.Print XMLHttp.ResponseText
  Set XMLHttp = Nothing
 

    Dim objCmdBrBtn As CommandBarButton
    
  CommandBars("Cell").Reset
  
  Set objCmdBrBtn = CommandBars("Cell").Controls.Add(msoControlButton, , , , True)
  
  With objCmdBrBtn
    .Caption = "Запуск обработки данных"
    .DescriptionText = "Показывает форму настройки"
    .enabled = True
    .OnAction = "ShowFormFilter"
    .TooltipText = "Запуск обработки данных"
    .Visible = True
    .FaceId = 2
  End With
 

Private Sub Workbook_Open()
  Call ReadSettings
  'Application.CommandBars.Reset
  'Application.CommandBars("НАДСТРОЙКИ").Reset
  With Application.CommandBars.Add(Name:="Menu", temporary:=True)
        .Visible = True
        With .Controls.Add
            .OnAction = "showformsettings"
            .Style = 2
            .Caption = "Parser"
            .FaceId = 25 ' - значок кнопки из стандартного набора офиса
        End With
    End With
End Sub
 

Function Extract_Number_from_Text(sWord As String, Optional Metod As Integer)
'sWord = ссылка на ячейку или непосредственно текст
'Metod = 0 – числа
'Metod = 1 – текст
    Dim sSymbol As String, sInsertWord As String
    Dim i As Integer
 
    If sWord = "" Then Extract_Number_from_Text = "Нет данных!": Exit Function
    sInsertWord = ""
    sSymbol = ""
    For i = 1 To Len(sWord)
        sSymbol = Mid(sWord, i, 1)
        If Metod = 1 Then
            If Not LCase(sSymbol) Like "*[0-9]*" Then
                If (sSymbol = "," Or sSymbol = "." Or sSymbol = " ") And i > 1 Then
                    If Mid(sWord, i - 1, 1) Like "*[0-9]*" And Mid(sWord, i + 1, 1) Like "*[0-9]*" Then
                        sSymbol = ""
                    End If
                End If
                sInsertWord = sInsertWord & sSymbol
            End If
        Else
            If LCase(sSymbol) Like "*[0-9.,;:-]*" Then
                If LCase(sSymbol) Like "*[.,]*" And i > 1 Then
                    If Not Mid(sWord, i - 1, 1) Like "*[0-9]*" Or Not Mid(sWord, i + 1, 1) Like "*[0-9]*" Then
                        sSymbol = ""
                    End If
                End If
                sInsertWord = sInsertWord & sSymbol
            End If
        End If
    Next i
    Extract_Number_from_Text = sInsertWord
End Function 

Sub PostForPostWP()
     'On Error Resume Next
     Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
     xmlhttp.Open "POST", "http://nonator.com/wp-login.php", "True"
     xmlhttp.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"    ' чтобы избежать кеширования
    Dim POST() As Byte, PostData$
      PostData = "log=test&pwd=test&rememberme=forever&wp-submit=%D0%92%D0%BE%D0%B9%D1%82%D0%B8&redirect_to=http%3A%2F%2Fnonator.com%2Fwp-admin%2F&testcookie=1"
'     PostData = PostData & "log=test"
'     PostData = PostData & "&pwd=test"
'     PostData = PostData & "&rememberme=forever"
'     PostData = PostData & "&wp-submit=Войти"
'     'PostData = PostData & "&redirect_to=http://nonator.com/wp-admin/post-new.php" 'post-new.php
'     PostData = PostData & "&testcookie=1"
     POST = StrConv(PostData, vbFromUnicode)
     xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
     xmlhttp.send (POST): DoEvents
     If xmlhttp.Status <> 200 Then Exit Sub
        Debug.Print xmlhttp.responseText
     Set xmlhttp = Nothing

End Sub
 

Private Sub Inf_Click()
 Inf.ControlTipText = CStr(Inf.List(Inf.ListIndex))
End Sub 

Function код(cell, cell2, cell3) As String
    Dim ws2, buf As Range
    Set ws2 = Sheets(2).Range("A:A")
'On Error Resume Next
    
'Set buf = ws2.Cells.Find(What:=cell.Value, LookIn:=xlFormulas, LookAt:=xlPart)
'Do While Not buf Is Nothing
'If (InStr(buf, cell2.Value) > 0) Or (InStr(buf, Left(cell3.Value, Len(cell3.Value) - 3)) > 0) Then
'   код = buf.Offset(0, 2).Value
'   exit do
'Else
'   Set buf = ws2.Cells.Findnext(buf)
'   код = "Не найдено"
'End If
'Wend


    Set buf = ws2.Cells.Find(What:=cell.Value + "*" + cell2.Value + "*" + Left(cell3.Value, Len(cell3.Value) - 3), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
    If buf Is Nothing Then
        Set buf = ws2.Cells.Find(What:=cell.Value + "*" + Left(cell3.Value, Len(cell3.Value) - 3) + "*" + cell2.Value, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
    If buf Is Nothing Then
        Set buf = ws2.Cells.Find(What:=cell.Value + "*" + cell2.Value, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
    If buf Is Nothing Then
        Set buf = ws2.Cells.Find(What:=cell.Value + "*" + Left(cell3.Value, Len(cell3.Value) - 3), LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
    If buf Is Nothing Then
        Set buf = ws2.Cells.Find(What:=cell.Value, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
    End If
    End If
    End If
    End If
    
    'If Not buf Is Nothing Then
        код = buf.Offset(0, 2).Value
'    Else
'        код = ws2.Cells.Find(What:=cell.Value, LookIn:=xlFormulas, _
'            LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False).Offset(0, 2).Value
'    End If
    
End Function

Function RowLingvo(txt As String) As String
Dim i As Integer, str As String, str2 As String, m As String
For i = 1 To Len(txt) ' пробегаем всю фразу по буквам
    m = Mid(txt, i, 1) ' берем очередную букву
    If m >= "A" And m <= "z" Then ' проверяем ее на кириллицу
        str2 = "" ' если кирилица то обнуляем слово
        Do ' запускаем цикл для определения очередного слова
            str2 = str2 & m 'приклеиваем к слову очередную буку
            i = i + 1 'накручиваем счетчик
            m = Mid(txt, i, 1) 'берем очередную букву
        Loop While m >= "A" And m <= "z" And i <= Len(txt) ' повторять пока слово не закончилось и не закончилась фраза
        i = i - 1 ' сбрасываем счетчик на 1
        
        If IsError(Application.VLookup(str2, Range("lingvo"), 2, 0)) Then ' проверяем слово на наличие в словаре
            str = str & str2 ' если слова нет, то не переводим
        Else
            str = str & Application.VLookup(str2, Range("lingvo"), 2, 0) ' переводим текущее слово
        End If
        
    Else
        str = str & m ' если символ не кириллица, то оставляем его без изминений
    End If
Next i ' следующая буква
RowLingvo = str ' возвращаем перевод
End Function
 

Function Translate$(ByVal TextToBeTranslated$, ByVal resultLanguageCode$, _
                    Optional ByVal sourceLanguageCode$ = "", Optional ByVal direction As Range)
    ' переводит текст TextToBeTranslated$ с языка sourceLanguageCode$
   ' на язык resultLanguageCode$, используя сервис переводов Google Translate
   Application.Volatile True
    Set ADOStream = CreateObject("ADODB.Stream")
    With ADOStream
        .Charset = "utf-8": .Mode = 3: .Type = 2: .Open
        .WriteText TextToBeTranslated: .Flush: .Position = 0
        .Type = 1: .Read 3: ByteArrayToEncode = .Read(): .Close
    End With

    For i = 0 To UBound(ByteArrayToEncode)
        iAsc = ByteArrayToEncode(i)
        Select Case iAsc    ' переводим текст в кодировку, понятную Google
           Case 32: sTemp$ = "+"    'space
           Case 48 To 57, 65 To 90, 97 To 122: sTemp$ = Chr(ByteArrayToEncode(i))
            Case Else: sTemp$ = "%" & Hex(iAsc)     'Chr(iAsc)
       End Select
        txt$ = txt$ & sTemp$
    Next

    ' формируем ссылку, по которой Google выдаст нам файл с переводом
   URL$ = "http://translate.google.com.ua/translate_a/t?client=json&text=" & _
           txt$ & "&hl=" & resultLanguageCode$ & "&sl=" & sourceLanguageCode$

    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")    ' скачиваем файл
   XMLHTTP.Open "GET", Replace(URL$, "\", "/"), "False": XMLHTTP.send

    If XMLHTTP.statustext = "OK" Then
        LocalPath$ = Environ("TMP") & "\google.txt"
        With ADOStream    ' перекодировка файла
           .Type = 1: .Open: .Write XMLHTTP.responseBody
            .SaveToFile LocalPath$, 2
            .Close: .Type = 2: .Charset = "utf-8": .Open:
            .LoadFromFile LocalPath$    ' загружаем данные из файла
           Translate$ = .ReadText   ' считываем текст файла в переменную Translate$
       End With

        On Error Resume Next    ' вырезаем нужный текст из ответа
       Translate$ = Split(Translate$, """trans"":""")(1)
        Translate$ = Split(Translate$, """,""orig")(0)
        Translate$ = Replace(Translate$, "quot;", Chr(39))
        If direction.Value <> "" Then direction.Value = Translate$
        If Translate$ = " null, " Then Translate$ = "Не переведено"
    End If
    Set XMLHTTP = Nothing: Set ADOStream = Nothing
End Function

Sub tt()
    Dim a(), b(), i&, ii&, buf$
'   a = Sheets(1).[a1].CurrentRegion.Value
    b = Sheets(2).[a1].CurrentRegion.Value
'простым перебором и заменой :
'    For i = 1 To UBound(a)
'        For ii = 1 To UBound(b)
'            buf$ = a(i, 1)
'            a(i, 1) = Replace(a(i, 1), b(ii, 1), b(ii, 2))
'            If a(i, 1) <> buf$ Then Exit For
'        Next
'    Next
'с помощью словаря
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(b): .Item(b(i, 1)) = b(i, 2): Next
        a = Sheets(1).[a1].CurrentRegion.Value
        For i = 1 To UBound(a)
            If .exists(a(i, 1)) Then a(i, 2) = .Item(a(i, 1))
        Next
        Sheets(1).[a1].CurrentRegion.Value = a
    End With
End Sub 

Function WebPageText(ByVal sURL, log, pass, edrpou As String, login As Boolean) As String
     On Error Resume Next
     Set IE = CreateObject("InternetExplorer.Application"):    ' open Internet Explorer
    With IE
    '.Visible = True 'видимость
    .Navigate sURL  ' переход
    While .Busy Or (.readyState <> 4): DoEvents: Wend    ' ожидание
   Set ieDoc = .Document: DoEvents: DoEvents
   If ieDoc.Title Like "Ошибка сертификата*" Or ieDoc.Title Like "Certificate Error*" Then
       ieDoc.Links(1).Click
       While IE.Busy Or (IE.readyState <> 4): DoEvents: Wend
       Set ieDoc = IE.Document
      End If

    With ieDoc 'login
    If login = True Then
      Application.Wait (Now + TimeValue("0:00:01"))
      .getElementsByName("mylogin")(0).Value = log
      .getElementsByName("mypass")(0).Value = pass
      .getElementsByName("savepass")(0).Click
      '.getElementsByName("login")(0).Click
      '.getElementsByValue("submit")(0).Click
      .forms(0).submit
      While IE.Busy Or (IE.readyState <> 4): DoEvents: Wend
    End If
     
      .getElementsByName("group1")(0).Click
      .getElementsByName("edrpou")(0).Value = edrpou
      '.getElementsByName("im1")(0).Click
      .forms(0).submit
      While IE.Busy Or (IE.readyState <> 4): DoEvents: Wend
      WebPageText = .body.innerText    ' тянем
       
    End With
    'Application.Wait (Now + TimeValue("0:00:13"))
     
    .Quit: Set IE = Nothing   ' закрываем
     End With
End Function