准备工作

工具准备

  • Excel365版本
  • WPS非会员安装VBA插件
  • 将文档启用宏模式并另存为宏工作簿：文件-选项-信任中心-宏设置-启用VBA

数据准备

  • 2023年全国各省行政区人口数据
  • 广东省2023年各市GDP数据

数据范围划分

  • 方法1：直接利用分位数划分数据（直接用五分位数将全国人口数据划分为五等份，分界值=ROUNDUP(PERCENTILE(数据所在列,分位点),0)）
  • 方法2：结合数据实际，自定义数据范围（如本例的划分）

色块填充

  • 颜色列文本框填充不同颜色

导入模板地图

  • 可在阿里云地图下载SVG格式的矢量地图模板,并导入excel
  • 矢量地图各板块命名：在Excel右上角处逐一修改各省市模块名称。

VBA代码编辑

  • 代码逻辑：遍历所有行，在每次循环中获取B列的人口数据，对其进行规则判断，取得对应规则单元格的背景色，用该背景色填充该行对应的省份名称形状。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Sub SetMapColor()

    Dim i As Integer  ' 定义变量
    Dim myColor As Long
    Dim dataSum As Integer
    
    dataSum = Range("A65535").End(xlUp).Row  ' 获取数据源的最后一行

    For i = 2 To dataSum  ' 从第2行开始遍历数据的所有行
    
        Select Case Range("B" & i).Value   ' 选择第2列的值进行判断
            Case Is <= Range("F3").Value
                myColor = Range("D2").Interior.Color
                
            Case Range("F3") To Range("F4")  ' F3和F4之间,填充D3单元格背景色
                myColor = Range("D3").Interior.Color
            
            Case Range("F4") To Range("F5")
                myColor = Range("D4").Interior.Color
                
            Case Range("F5") To Range("F6")
                myColor = Range("D5").Interior.Color
                
            Case Else
                myColor = Range("D6").Interior.Color
                
        End Select
            
            ActiveSheet.Shapes(Range("A" & i).Value).Fill.ForeColor.RGB = myColor  ' 根据形状名称选择形状并填充颜色

        Next
        
End Sub

添加地图标签

标签添加VBA代码编辑

  • 给各省市模块添加名字，也可添加数据标签
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    Sub HeatMap_fill_text()

        Dim cityName As String    ' 定义名称
        Dim shapeObj As shape
        Dim textBox As shape
        
        dataSum = Range("A65535").End(xlUp).Row  ' 获取数据源结束行

        For i = 2 To dataSum ' 数据源的起始和结束行
            cityName = Range("A" & i).Value ' 获取当前城市名称
            Set shapeObj = ActiveSheet.Shapes(cityName) ' 获取形状对象
            On Error GoTo 0 ' 关闭错误处理

            If Not shapeObj Is Nothing Then
                ' 在形状上添加文本框
                Set textBox = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                        shapeObj.Left, shapeObj.Top + (shapeObj.Height / 2) - 10, shapeObj.Width, 20)
                
                ' 设置文本框的内容为城市名称
                textBox.TextFrame.Characters.Text = cityName
                
                ' 确保文本框中的文本可见并设置为楷体
                With textBox.TextFrame.Characters
                    .Font.Name = "华文楷体" ' 设置字体为华文楷体
                    .Font.Size = 6 ' 字体大小
                    .Font.Color = RGB(0, 0, 0) ' 字体颜色（黑色）
                End With
                
                ' 使文本框的背景透明
                textBox.Fill.Visible = msoFalse ' 使文本框的背景透明
                
                ' 去掉文本框的边框
                textBox.Line.Visible = msoFalse ' 隐藏文本框边框
                
                ' 将文本框的对齐方式设置为居中
                textBox.TextFrame.HorizontalAlignment = xlHAlignCenter
                textBox.TextFrame.VerticalAlignment = xlVAlignCenter
            Else
                MsgBox "未找到名为 " & cityName & " 的形状！"
            End If
        Next i
    End Sub

标签删除VBA代码编辑

  • 删除地图形状的所有文本框,即文本标签
    1
    2
    3
    4
    5

    Sub DeleteAllTextBoxes()
        ActiveSheet.TextBoxes.Delete
    End Sub

添加表单控件

  • 开发工具-插入-表单空间-第一个工具
  • 右键单击控件-指定宏-选中对应的宏进行绑定，点击控件进行宏操作。

Excel技巧

  • 选中所有文本框OR图像形状：Crtl+G–定位条件-对象