如何在excel中用vba采集中华人民共和国行政区划代码？

中华人民共和国行政区划代码会每年都有变更，为了获取到最新的中华人民共和国行政区划代码可以通过网络采集的形式不断地获取最新的中华人民共和国行政区划代码。

比如中华人民共和国民政部官方网站会不定期的更新中华人民共和国行政区划代码。

如本链接为2017年中华人民共和国行政区划代码（截止2017年12月31日）

本文介绍用WinHttpRequest对象通过以下代码获取到截止2017年12月31日的最新的中华人民共和国行政区划代码：

Sub QQ1722187970()
    Excel.Application.ScreenUpdating = False
    Excel.Application.Calculation = xlCalculationManual
    Dim sVerb As String
    Dim sUrl As String
    Dim sCharset As String
    Dim sPostData As String
    sVerb = "GET"
    sUrl = "http://www.mca.gov.cn/article/sj/tjbz/a/2018/201803131439.html"
    sResult = HtmlBasic("GET", sUrl)
    Call HtmlTable(sResult)
    Excel.Application.Calculation = xlCalculationAutomatic
    Excel.Application.ScreenUpdating = True
End Sub
Function HtmlBasic(ByVal sVerb As String, ByVal sUrl As String, Optional ByVal sCharset As String = "utf-8", Optional ByVal sPostData As String = "")
    'sVerb为发送的Html请求的方法,sUrl为具体的网址,sCharset为网址对应的字符集编码,sPostData为Post方法对应的发送body
    Dim oHTML As Object
    'https://msdn.microsoft.com/en-us/library/windows/desktop/aa384106(v=vs.85).aspx
    Set oHTML = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")
    With oHTML
        Select Case sVerb
        Case "GET"
        .Open "GET", sUrl, False
        Case "POST"
        .Open "POST", sUrl, False
'        .SetRequestHeader "Referer", "http://www.77tj.org/tencent"
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        End Select
        .send (sPostData)
        '获取返回的字节数组
        bResult = .ResponseBody
        '按照指定的字符编码显示
        sResult = Byte2String(bResult, sCharset)
        Debug.Print sResult
        HtmlBasic = sResult
    End With
    Set oHTML = Nothing
End Function
Function Byte2String(bContent, ByVal sCharset As String)
    Const adTypeBinary = 1
    Const adTypeText = 2
    Const adModeRead = 1
    Const adModeWrite = 2
    Const adModeReadWrite = 3
    Dim oStream As Object
    '创建流对象
    Set oStream = CreateObject("ADODB.Stream")
    With oStream
        '打开流
        .Open
        '设置为字节模式
        .Type = adTypeBinary
        '写入字节
        .write bContent
        '将位置定位在第一个字节
        .Position = 0
        '设置为文本模式
        .Type = adTypeText
        '设置编码的字符集
        .Charset = sCharset
        '读取编码后的文本
         Byte2String = .ReadText
        '关闭流对象
        .Close
    End With
End Function
'提取网页表格的代码
Sub HtmlTable(ByVal sHtml As String)
    '网页html文档对象
    Dim oHtmlDom As Object
    '网页表格对象
    Dim oTable As Object
    '网页表格行对象
    Dim oRows As Object
    '网页表格单元格对象
    Dim oCells As Object
    '抓取的数据存放的excel表格对象
    Dim oWK As Worksheet
    Set oWK = Sheet1
    oWK.Cells.Clear
    iRow = oWK.Range("a65536").End(xlUp).Row
    Set oHtmlDom = CreateObject("htmlfile")
    With oHtmlDom
        .body.innerHTML = sHtml
        Set oTable = .getElementsByTagName("table")(0)
        'Set obj = getElementById("id")
        With oTable
            Set oRows = .Rows
            For i = 2 To oRows.Length - 1
                Set oCells = oRows(i).Cells
                For j = 0 To oCells.Length - 1
                    oWK.Cells(iRow, j + 1) = oCells(j).innertext
                Next j
                iRow = iRow + 1
            Next i
        End With
    End With
    oWK.Range("a1").EntireColumn.Delete
    Set oHtmlDom = Nothing
    Set oTable = Nothing
    Set oRows = Nothing
    Set oCells = Nothing
End Sub