如何用VBA函数结合Google Places API提取并格式化单元格地址

原代码问题分析 #

你的代码存在几个核心问题导致无法正常执行：

• 未对输入的address参数做URL编码，特殊字符会破坏API请求格式
• 解析JSON时未正确遍历API返回的层级结构，直接引用formatted_address会触发错误
• 缺少基础的错误处理逻辑，API请求失败或无匹配结果时会直接崩溃

修正后的完整代码 #

Function FindAddress(address As String, APIKEY As String) As String
    Dim strURL As String
    Dim httpReq As Object
    Dim Response As String
    Dim parsed As Dictionary
    Dim candidates As Collection
    Dim candidate As Dictionary
    Dim formattedAddr As String
    Dim tempAddr As String
    Dim postalCode As String
    
    ' 对地址参数做URL编码，避免特殊字符导致请求失败
    address = WorksheetFunction.EncodeURL(address)
    
    ' 构造API请求URL，只请求需要的字段以减少返回数据量
    strURL = "https://maps.googleapis.com/maps/api/place/findplacefromtext/json?" & _
             "fields=formatted_address&input=" & address & _
             "&inputtype=textquery&key=" & APIKEY
    
    ' 创建高版本HTTP请求对象，提升兼容性
    Set httpReq = CreateObject("MSXML2.XMLHTTP.6.0")
    With httpReq
        .Open "GET", strURL, False
        .Send
        ' 检查请求是否成功
        If .Status <> 200 Then
            FindAddress = "请求失败：" & .StatusText
            Exit Function
        End If
        Response = .ResponseText
    End With
    
    ' 解析JSON响应，添加错误捕获
    On Error Resume Next
    Set parsed = JsonConverter.ParseJson(Response)
    If Err.Number <> 0 Then
        FindAddress = "JSON解析失败"
        Exit Function
    End If
    On Error GoTo 0
    
    ' 检查API返回状态
    If parsed("status") <> "OK" Then
        FindAddress = "未找到地址：" & parsed("status")
        Exit Function
    End If
    
    Set candidates = parsed("candidates")
    If candidates.Count = 0 Then
        FindAddress = "无匹配地址"
        Exit Function
    End If
    
    ' 获取第一个匹配的格式化地址
    Set candidate = candidates(1)
    formattedAddr = candidate("formatted_address")
    
    ' 移除国家后缀（示例为", Nederland"，可根据实际需求调整）
    tempAddr = Left(formattedAddr, InStrRev(formattedAddr, ", Nederland") - 1)
    
    ' 清洗邮编：移除空格（适配荷兰邮编格式，可修改正则匹配其他国家）
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\b\d{4}\s?[A-Z]{2}\b" ' 匹配4位数字+2位大写字母的邮编格式
    regex.Global = False
    If regex.Test(tempAddr) Then
        postalCode = regex.Execute(tempAddr)(0).Value
        postalCode = Replace(postalCode, " ", "")
        tempAddr = regex.Replace(tempAddr, postalCode)
    End If
    
    ' 返回最终格式化地址
    FindAddress = tempAddr
    
    ' 释放对象
    Set httpReq = Nothing
    Set parsed = Nothing
    Set candidates = Nothing
    Set candidate = Nothing
    Set regex = Nothing
End Function

关键改进说明 #

• URL编码处理：用WorksheetFunction.EncodeURL对输入地址编码，确保空格、逗号等特殊字符不会破坏请求结构
• 高版本HTTP对象：使用MSXML2.XMLHTTP.6.0替代旧版本，提升兼容性和稳定性
• 全链路错误处理：添加请求状态检查、JSON解析错误捕获、API状态码判断，避免函数崩溃
• 地址格式化逻辑：
  1. 精准移除指定国家后缀（", Nederland"）
  2. 用正则表达式匹配并清洗邮编，自动移除其中的空格
• 字段精简：API请求仅保留formatted_address字段，减少返回数据量，提升执行效率

使用方法 #

1. 确保已正确导入VBA-JSON模块（JsonConverter.bas）
2. 在Excel单元格中调用函数：=FindAddress("待查询地址", "你的Google Places API密钥")

内容的提问来源于stack exchange，提问作者Rvok