研究需要用到经纬度转地址所在的省、市、县或区，因此借用高德地图API完成，设定一个自定义公式，在vba界面中的模块中添加：
Option Explicit
'**************** 把这里换成你的高德 Web 服务 Key *****************
Private Const GAODE_KEY As String = "ca993423c6ccc947db745a28f83abc79" '改成自己的
'********************************************************************
'================= 用户直接调用的 UDF =================
Public Function GetAddressFromLatLng(lat As Double, lng As Double) As String
On Error GoTo ErrH
Dim url As String
url = "https://restapi.amap.com/v3/geocode/regeo?key=" & GAODE_KEY & "&location=" & lat & "," & lng & "&poitype=&radius=&extensions=base&roadlevel=0"
Dim resp As String
resp = HttpGet(url)
If InStr(resp, """status"":""1""") = 0 Then
GetAddressFromLatLng = "API错误：" & GetJsonItem(resp, "info")
Exit Function
End If
' 提取 province-city-district 格式
GetAddressFromLatLng = GetProvinceCityDistrict(resp)
Exit Function
ErrH:
GetAddressFromLatLng = "异常：" & Err.Description
End Function
'===================== HTTP 请求（WinHttp） =====================
Private Function HttpGet(url As String) As String
On Error GoTo ErrH
Dim h As Object
Set h = CreateObject("WinHttp.WinHttpRequest.5.1")
h.Open "GET", url, False
h.Send
HttpGet = h.ResponseText
Exit Function
ErrH:
' 万一 WinHttp 被禁用，退而求其次用 XMLHTTP
Dim x As Object
Set x = CreateObject("Microsoft.XMLHTTP")
x.Open "GET", url, False
x.Send
HttpGet = x.ResponseText
End Function
Private Function GetProvinceCityDistrict(json As String) As String
Dim province As String, city As String, district As String
Dim addrComp As String
Dim pStart As Long, pEnd As Long
' 1. 先定位到 addressComponent 部分
pStart = InStr(json, """addressComponent""")
If pStart = 0 Then
GetProvinceCityDistrict = "未找到addressComponent"
Exit Function
End If
' 找到 addressComponent 的开始大括号
pStart = InStr(pStart, json, "{")
If pStart = 0 Then
GetProvinceCityDistrict = "解析错误"
Exit Function
End If
' 找到对应的结束大括号（简单处理：找下一个 "regeocode" 或文件尾）
pEnd = InStr(pStart, json, """pois""")
If pEnd = 0 Then pEnd = Len(json)
' 提取 addressComponent 片段
addrComp = Mid(json, pStart, pEnd - pStart)
' 2. 提取 province
province = GetJsonItem(addrComp, "province")
' 3. 提取 city（可能是空数组 []）
city = GetJsonItem(addrComp, "city")
' 如果 city 是空数组或空字符串，使用 province 作为 city（直辖市情况）
If city = "[]" Or city = "" Then
city = province
End If
' 4. 提取 district
district = GetJsonItem(addrComp, "district")
' 5. 组合成 province-city-district 格式
GetProvinceCityDistrict = province & "-" & city & "-" & district
End Function
'不用任何外部库，纯字符串截取
Private Function GetJsonItem(json As String, key As String) As String
Dim p As Long, q As Long
Dim startPos As Long, endPos As Long
Dim value As String
p = InStr(json, """" & key & """") '找到 key
If p = 0 Then Exit Function
p = InStr(p, json, ":") + 1 '冒号后
Do While Mid(json, p, 1) = " " '去空格
p = p + 1
Loop
If Mid(json, p, 1) = """" Then '字符串
p = p + 1
q = InStr(p, json, """")
If q = 0 Then Exit Function
GetJsonItem = Mid(json, p, q - p)
ElseIf Mid(json, p, 1) = "[" Then '数组（如空数组 []）
' 找到匹配的 ]
startPos = p
endPos = InStr(startPos, json, "]")
If endPos = 0 Then Exit Function
GetJsonItem = Mid(json, startPos, endPos - startPos + 1)
Else '数字或其他
q = InStr(p, json, ",")
If q = 0 Then q = InStr(p, json, "}")
If q = 0 Then q = InStr(p, json, "]")
If q = 0 Then q = Len(json) + 1
GetJsonItem = Trim(Mid(json, p, q - p))
End If
End Function
除此之外，还需要额外再ThisWorkBook中设置自动填写公式函数，避免下拉公式过度密集请求网址。
'==================== 模块顶部（所有 Sub 之前） ====================
#If VBA7 Then
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
'==================================================================
Sub FillAllWithDelay_QPS()
Const ERR_TEXT As String = "API错误：CUQPS_HAS_EXCEEDED_THE_LIMIT"
Dim r As Long
Application.StatusBar = "开始填充 … 按 Esc 可中断"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For r = 2 To 518
DoEvents
If GetAsyncKeyState(vbKeyEscape) Then Exit For
'--------- 预检查：只有错误才重填 ---------
If CStr(Cells(r, "Y").value) <> ERR_TEXT Then GoTo NextRow
'--------- 写公式 ---------
Cells(r, "Y").Formula = "=GetAddressFromLatLng(B" & r & ",C" & r & ")"
'--------- 后检查：错误则 1 秒重试 ---------
Do While CStr(Cells(r, "Y").value) = ERR_TEXT
Application.Wait Now + TimeSerial(0, 0, 2) '2 秒
Cells(r, "Y").Formula = "=GetAddressFromLatLng(B" & r & ",C" & r & ")"
DoEvents
If GetAsyncKeyState(vbKeyEscape) Then Exit Sub
Loop
NextRow:
Application.StatusBar = "已处理第 " & r & " 行"
Next r
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "已完成到第 " & r - 1 & " 行", vbInformation
End Sub