Výslední excel měl vypadat takto:
Do chybějící ulie jsem tedy doplnil název institutu a sestavil makro, které pomocí API mapy.com poplní PSČ. K použití API je potřeba získat z https://developer.mapy.com/cs/rest-api/jak-zacit/ API klíč.
Celý modul ve VBA pak vypadá následovně:
Option Explicit
Const MAPY_API_KEY As String = "MujAPIklicDevelopera"
' --- UTF-8 URL-encode pomocí ADODB.Stream ---
Function URLEncodeUTF8(s As String) As String
Dim stm As Object
Dim bytes() As Byte
Dim i As Long
Dim ch As Long
Dim out As String
Set stm = CreateObject("ADODB.Stream")
stm.Type = 2 ' text
stm.Charset = "utf-8"
stm.Open
stm.WriteText s
stm.Position = 0
stm.Type = 1 ' binary
bytes = stm.Read
stm.Close
out = ""
For i = 0 To UBound(bytes)
ch = bytes(i)
If (ch >= 48 And ch <= 57) Or (ch >= 65 And ch <= 90) Or (ch >= 97 And ch <= 122) Or ch = 45 Or ch = 46 Or ch = 95 Or ch = 126 Then
out = out & Chr(ch)
Else
out = out & "%" & Right("0" & Hex(ch), 2)
End If
Next i
URLEncodeUTF8 = out
End Function
' --- Extrakce zip pomocí regulárního výrazu ---
Function ExtractZipFromJson(json As String) As String
Dim re As Object
Dim matches As Object
Dim candidate As String
Set re = CreateObject("VBScript.RegExp")
re.Pattern = """zip""\s*:\s*""([^""]+)"""
re.IgnoreCase = True
re.Global = False
If re.Test(json) Then
Set matches = re.Execute(json)
candidate = Trim(matches(0).SubMatches(0))
candidate = Replace(candidate, vbTab, " ")
candidate = Replace(candidate, vbCr, "")
candidate = Replace(candidate, vbLf, "")
candidate = Trim(candidate)
If Len(candidate) = 5 And InStr(candidate, " ") = 0 Then
candidate = Left(candidate, 3) & " " & Right(candidate, 2)
End If
ExtractZipFromJson = candidate
Else
ExtractZipFromJson = ""
End If
End Function
' --- Testovací Sub pro ověření volání API a dekódování UTF-8 ---
Sub Test_MapyCZ_Request()
Dim http As Object
Dim url As String
Dim adresa As String
Dim encoded As String
Dim bytes() As Byte
Dim stm As Object
Dim response As String
Dim statusCode As Long
Dim zip As String
On Error GoTo ErrHandler
adresa = "Křižíkova 188 Brno" ' změň podle potřeby
encoded = URLEncodeUTF8(adresa)
url = "https://api.mapy.cz/v1/suggest?apikey=" & MAPY_API_KEY & "&limit=1&query=" & encoded
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
http.Open "GET", url, False
http.setRequestHeader "User-Agent", "ExcelVBA"
http.send
statusCode = http.Status
If statusCode <> 200 Then
ThisWorkbook.Sheets(1).Range("Z1").Value = "HTTP Status: " & statusCode & " - " & http.statusText
Exit Sub
End If
bytes = http.responseBody
' Převod raw bytes (UTF-8) na text pomocí ADODB.Stream
Set stm = CreateObject("ADODB.Stream")
stm.Type = 1 ' binary
stm.Open
stm.Write bytes
stm.Position = 0
stm.Type = 2 ' text
stm.Charset = "utf-8"
response = stm.ReadText
stm.Close
ThisWorkbook.Sheets(1).Range("Z1").Value = response
zip = ExtractZipFromJson(response)
If zip <> "" Then
ThisWorkbook.Sheets(1).Range("Z2").Value = zip
Else
ThisWorkbook.Sheets(1).Range("Z2").Value = "zip not found"
End If
MsgBox "Hotovo. Podívej se do Z1 (raw JSON) a Z2 (zip).", vbInformation
Exit Sub
ErrHandler:
ThisWorkbook.Sheets(1).Range("Z1").Value = "CHYBA: " & Err.Number & " - " & Err.Description
MsgBox "Chyba: " & Err.Description, vbExclamation
End Sub
' --- Hlavní sub pro hromadné doplnění PSČ (pouze C,D -> E), bez LOGu ---
Sub DoplnitPSC_Hromadne()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim ulice As String, mesto As String, adresa As String
Dim encoded As String, url As String
Dim http As Object
Dim bytes() As Byte, response As String
Dim zip As String
Dim stm As Object
Dim statusCode As Long
Dim pauseMs As Long
Dim processed As Long, skipped As Long
Dim startRow As Long
' Nastavení
pauseMs = 200 ' pauza mezi dotazy v ms
startRow = 2 ' uprav pokud máš jiný počet hlaviček
Set ws = ThisWorkbook.Sheets(1) ' změň na Worksheets("NázevListu") pokud potřebuješ
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
processed = 0: skipped = 0
For i = startRow To lastRow
' pracujeme výhradně se sloupci C (ulice), D (město), E (psc)
ulice = Trim(ws.Cells(i, "C").Value)
mesto = Trim(ws.Cells(i, "D").Value)
' Přeskočit prázdné řádky (C i D prázdné)
If ulice = "" And mesto = "" Then
skipped = skipped + 1
GoTo NextRow
End If
' Přeskočit, pokud E už obsahuje platnou hodnotu (nechceme přepisovat)
If Trim(ws.Cells(i, "E").Value) <> "" And _
Trim(ws.Cells(i, "E").Value) <> "0" And _
LCase(Trim(ws.Cells(i, "E").Value)) <> "n" And _
LCase(Trim(ws.Cells(i, "E").Value)) <> "není" Then
skipped = skipped + 1
GoTo NextRow
End If
' Přeskočit řádky, kde C vypadá jako JSON nebo obsahuje "items"
If Left(ulice, 1) = "{" Or InStr(1, ulice, "items", vbTextCompare) > 0 Then
skipped = skipped + 1
GoTo NextRow
End If
' Sestav adresu pouze z C a D
adresa = ulice
If mesto <> "" Then adresa = adresa & ", " & mesto
' Volání API
encoded = URLEncodeUTF8(adresa)
url = "https://api.mapy.cz/v1/suggest?apikey=" & MAPY_API_KEY & "&limit=1&query=" & encoded
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
On Error Resume Next
http.Open "GET", url, False
http.setRequestHeader "User-Agent", "ExcelVBA"
http.send
On Error GoTo 0
On Error GoTo RequestError
statusCode = http.Status
If statusCode <> 200 Then
ws.Cells(i, "E").Value = "?"
GoTo PauseAndContinue
End If
bytes = http.responseBody
' Převod raw bytes (UTF-8) na text pomocí ADODB.Stream
Set stm = CreateObject("ADODB.Stream")
stm.Type = 1 ' binary
stm.Open
stm.Write bytes
stm.Position = 0
stm.Type = 2 ' text
stm.Charset = "utf-8"
response = stm.ReadText
stm.Close
' Extrahuj zip
zip = ExtractZipFromJson(response)
If zip <> "" Then
ws.Cells(i, "E").Value = zip
Else
ws.Cells(i, "E").Value = "?"
End If
processed = processed + 1
PauseAndContinue:
' Pauza mezi dotazy
If pauseMs > 0 Then
Dim t0 As Double
t0 = Timer
Do While Timer < t0 + pauseMs / 1000
DoEvents
Loop
End If
NextRow:
' pokračuj
Next i
MsgBox "Hotovo. Zapsáno: " & processed & " adres. Přeskočeno: " & skipped & ".", vbInformation
Exit Sub
RequestError:
ws.Cells(i, "E").Value = "?"
Resume PauseAndContinue
End Sub
