Excel~绘制数据地图及获取各省份天气信息

Excel 是一款强大的数据处理软件，我们可以通过他实现日常工作中遇到的绝大部分数据处理及分析问题。在做数据分析的过程中，我们经常需要一些图表使数据更加直观形象，Excel 提供了强大的条形图、饼图、折线图、雷达图等图表来满足我们的使用需求，然而有些时候现有的图表功能有限，我们希望自定义一些更高大上的数据图表以使得数据分析更优美，数据地图既是其中之一。这里分享下个人使用 Excel 生成数据地图并自动获取天气信息的方法。先看下效果：

SVG 地图的处理

在制作数据地图前，首先我们需要一张 SVG 格式的地图图片。你可以自己制作一张，也可以从这里搜一张>>> https://commons.wikimedia.org/wiki/File:China_blank_province_map.svg

注意：下载的话务必选择 Full resolution！

然后就是图片处理，一般情况下下载下来的图片需要转换为 .emf 格式文件，我们可以通过 InkScape 这款软件转换一下，软件下载请戳这里>>> https://inkscape.org/

图片处理完成后导入 Excel 文件即可，不过需要注意的是导入文件后需要右键取消组合，在取消组合的过程中常常会出现图形曲线乱掉的问题，这里可以通过将导入的图片对齐左上角避免掉。

数据区域的划分

因为我们希望根据不同地区的天气使不同地区显示不同颜色，所以这里需要定义一些数据区域用于存储数据。定义的数据区域如下：

为什么要设置数据区域，一方面是为了方便大家对应相应的数据项目，避免直接引用单元格区域造成的代码困惑；另一方面是为了避免由于剪切数据项目，移动数据项目位置造成的单元格引用失效等问题。

定义完成数据区域后通过 VBA 代码控制颜色显示及天气数据获取即可。

VBA 代码的解释

先看下工程文件的代码分类，如下图：

Functions

Functions 模块中主要是为了实现点击按钮改变颜色以使得点击模块更有操作感。主要是通过 OnTime 计时器实现的效果，不过可惜 VBA 的计时器间隔时间最小是 1s 效果有限，见谅。

'获取选中对象的名称
Public theShape, color_old

Function oldColor()
    ActiveSheet.Shapes(theShape).Fill.ForeColor.RGB = color_old
End Function
Function changeColorOnShapeClick()
    theShape = Application.Caller
    color_old = ActiveSheet.Shapes(theShape).Fill.ForeColor
    ActiveSheet.Shapes(theShape).Fill.ForeColor.RGB = RGB(51, 153, 255)
    Application.OnTime Now + TimeValue("00:00:01"), "oldColor"
End Function

需要注意的是，因为间隔时间为 1s 如果连续点击的话可能颜色恢复不回去。

Province

Province 模块中主要是获取当前省份信息执行 Weather 中相关函数获取天气信息的代码，及自动根据数据填充数据地图颜色的相关代码。

Sub getCurrentProvince()
    Call changeColorOnShapeClick
    ActiveSheet.Range("Current_Province").Value = Application.Caller
    Call getProvinceWeather
End Sub

Sub fillByNum()
    For i = 1 To 34
       Range("ActProvince").Value = Range("Province_Info").Cells(i, 1).Value
       ActiveSheet.Shapes(Range("ActProvince").Value).Select
       Selection.ShapeRange.Fill.ForeColor.RGB = Range(Range("ActTempCode").Value).Interior.Color
    Next i
    Range("A1").Select
End Sub

Sub btnMapRefresh()
    theShape = Application.Caller
    color_old = ActiveSheet.Shapes(theShape).Fill.ForeColor
    ActiveSheet.Shapes(theShape).Fill.ForeColor.RGB = RGB(0, 112, 192)
    Application.OnTime Now + TimeValue("00:00:01"), "oldColor"
    Call fillByNum
End Sub

Sub getProvinceWeather()
   Call getWeatherByCity(Range("Current_Province_Capital").Value, Range("Current_Province_Capital_Code").Value)
   Range("A1").Select
End Sub

Weather

Weather 模块中的代码是爬取网站上天气数据的相关代码，这一块单独放在一个模块中方便大家理解。

Function getWeatherByCity(theCity As String, theCode As String)

    Dim shp As Shape, URL$, responseText As String, moreWeather As String, moreWeatherBody As String, nowWeather As String
    Application.ScreenUpdating = False
    Cells.UnMerge
    Range("Province_Weather_Now").ClearContents
    Range("Province_Weather_More").ClearContents
    '清除原有图片
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then
            shp.Delete
        End If
    Next
    
    URL = "https://www.15tianqi.com/" & theCode & "/"
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .setRequestHeader "Connection", "keep-alive"
        .send "firstime=1445386631433; lasttime=1445386631903; count=0"
        responseText = .responseText                          '爬取整个网页信息
        
        '截取当日天气信息
        nowWeather = "<table><td><dl>" & Split(Split(responseText, theCity & "今日天气预报</dt>")(1), "</td>")(0) & "</td></table>"
        nowWeather = Replace(nowWeather, "/Images", "http://www.15tianqi.com/Images")
        
        CopyToClipbox nowWeather
        Range("M7").Select
        ActiveSheet.Paste
        
        '截取全部天气信息
        moreWeatherWrap = "<table" & Split(Split(responseText, "<table")(3), "</table>")(0) & "</table>"        'Split(expression[,delimiter[,count[,compare]]])   网页中有 4 个table表格，获取第三个既是我们要的数据
        moreWeatherHead = "<thead" & Split(Split(moreWeatherWrap, "<thead")(2), "</thead>")(0) & "</thead>"
        moreWeatherBody = "<tbody" & Split(Split(moreWeatherWrap, "<tbody")(1), "</tbody>")(0) & "</tbody>"
        moreWeather = "<table>" & moreWeatherHead & moreWeatherBody & "</table>"
        moreWeather = Replace(moreWeather, "/Images", "http://www.15tianqi.com/Images")        'Replace(expression、 find、 replace、[ start、[ count, [ compare ]]])
        
        CopyToClipbox moreWeather
        Range("M16").Select
        ActiveSheet.Paste
        
    End With
    
'    '清除原有图片
'    For Each drt In ActiveSheet.Shapes
'        If Not Intersect(drt.TopLeftCell, [S32:K1048576]) Is Nothing Then drt.Delete
'        If Not Intersect(drt.BottomRightCell, [S32:K1048576]) Is Nothing Then drt.Delete
'    Next
    
    Application.ScreenUpdating = True
    
End Function
Function CopyToClipbox(strText As String)
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText strText
        .PutInClipboard
    End With
End Function

以上代码基于网上多处代码优化调整所得，具体当初找的哪里的代码我也记不清了(╯︵╰)，好长时间前就想分享了，工作比较忙一直拖到现在。。。