|
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 |
|
|
|
|
This comment has been minimized.
meziniakov commentedNov 20, 2018
Подскажите, пожалуйста, как изменить код, чтобы можно было в столбце А в каждую ячейку вставлять свой запрос (ИНН), а в соседних ячейках появлялись бы реквизиты компаний из Подсказок?
Спасибо.