Create a gist now

Instantly share code, notes, and snippets.

@nalgeon /README.md
Last active Jun 7, 2018

Embed
Пример вызова Подсказок DaData.ru из Excel

Как подключить пример

  1. Откройте Excel и включите отображение вкладки «Разработчик»
  2. Перейдите в редактор Visual Basic (в ленте Разработчик > Visual Basic).
  3. Откройте список ссылок: в меню Tools > References...
  4. Отметьте пункты «Microsoft Scripting Runtime» и «Microsoft VBScript Regular Expressions 5.5».
  5. Нажмите OK.
  6. Откройте модуль Лист1.
  7. Скопируйте код из примера в модуль.
  8. Замените значение константы API_KEY с CHANGE_ME на ваш API-ключ.

Как работает пример

Введите название компании или ИНН в ячейку A1, нажмите «энтер». В соседних ячейках появятся реквизиты компании из Подсказок.

Private Const API_KEY = "CHANGE_ME"
Private pCachedRegexes As Dictionary
Public Function GetRegex( _
ByVal pattern As String, _
Optional ByVal IgnoreCase As Boolean = True, _
Optional ByVal MultiLine As Boolean = True, _
Optional ByVal MatchGlobal As Boolean = True) As RegExp
' Ensure the dictionary has been initialized
If pCachedRegexes Is Nothing Then Set pCachedRegexes = New Dictionary
' Build the unique key for the regex: a combination
' of the boolean properties and the pattern itself
Dim rxKey As String
rxKey = IIf(IgnoreCase, "1", "0") & _
IIf(MultiLine, "1", "0") & _
IIf(MatchGlobal, "1", "0") & _
pattern
' If the RegExp object doesn't already exist, create it
If Not pCachedRegexes.Exists(rxKey) Then
Dim oRegExp As New RegExp
With oRegExp
.pattern = pattern
.IgnoreCase = IgnoreCase
.MultiLine = MultiLine
.Global = MatchGlobal
End With
Set pCachedRegexes(rxKey) = oRegExp
End If
' Fetch and return the pre-compiled RegExp object
Set GetRegex = pCachedRegexes(rxKey)
End Function
Function Utf8ToAscii(ByVal txt) As String
On Error Resume Next: Err.Clear
With CreateObject("ADODB.Stream")
.Type = 1
.Open
.Write txt
.Position = 0
.Type = 2
.Charset = "UTF-8"
Utf8ToAscii = .ReadText
.Close
End With
End Function
Function Suggest(ByVal name, ByVal query, ByVal count) As String
Dim http
Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
timeout = 2000 'milliseconds
http.setTimeouts timeout, timeout, timeout, timeout
request = "{ ""query"": """ & query & """, ""count"": """ & count & """ }"
http.Open "POST", "https://suggestions.dadata.ru/suggestions/api/4_1/rs/suggest/" & name
http.setRequestHeader "Content-Type", "application/json"
http.setRequestHeader "Authorization", "Token " & API_KEY
http.send request
suggestions = Replace(http.responseText, "\""", "")
Debug.Print suggestions
Suggest = suggestions
End Function
Function Extract(ByVal fieldName, ByVal suggestion)
rePattern = "^.+""" & fieldName & """:""([^""]+)"".+$"
Debug.Print "Pattern: " & rePattern
Dim re As RegExp
Set re = GetRegex(rePattern)
If re.Test(suggestion) Then
result = re.Replace(suggestion, "$1")
Else
result = ""
End If
Debug.Print "Extracted: " & result
Extract = result
End Function
Function ExtractName(suggestion) As String
ExtractName = Extract("suggestions.....value", suggestion)
End Function
Function ExtractOGRN(suggestion) As String
ExtractOGRN = Extract("ogrn", suggestion)
End Function
Function ExtractINN(suggestion) As String
ExtractINN = Extract("inn", suggestion)
End Function
Function ExtractKPP(suggestion) As String
ExtractKPP = Extract("kpp", suggestion)
End Function
Function ExtractOKVED(suggestion) As String
ExtractOKVED = Extract("okved", suggestion)
End Function
Function ExtractAddress(suggestion) As String
ExtractAddress = Extract("address....value", suggestion)
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
If Target.Address = "$A$1" Then
Debug.Print "Source: " & Target.Value
suggested = Suggest("party", Target.Value, 1)
'Debug.Print "Suggested: " & suggested
Range("B1").Value = ExtractName(suggested)
Range("C1").Value = ExtractOGRN(suggested)
Range("D1").Value = ExtractINN(suggested)
Range("E1").Value = ExtractKPP(suggested)
Range("F1").Value = ExtractOKVED(suggested)
Range("G1").Value = ExtractAddress(suggested)
End If
End Sub
@zukerman19

This comment has been minimized.

Show comment
Hide comment
@zukerman19

zukerman19 Apr 12, 2018

Привет, При работе макроса выдает ошибку что время ожидания операции истекло.
Значение переменной timeout меняю на большее количество миллисекунд, но ошибка не исчезает.
Как исправить ошибку? подскажите?

Привет, При работе макроса выдает ошибку что время ожидания операции истекло.
Значение переменной timeout меняю на большее количество миллисекунд, но ошибка не исчезает.
Как исправить ошибку? подскажите?

@Zorro05

This comment has been minimized.

Show comment
Hide comment
@Zorro05

Zorro05 Jun 7, 2018

@zukerman19 , пиши в ТП.

Zorro05 commented Jun 7, 2018

@zukerman19 , пиши в ТП.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment