今天分享一个用excel做的地图查询小工具：通过选择省份，显示该省的基本情况介绍、美食、旅游景点等信息，同时地图中该省区域突出标记显示，不仅能查询美食景点，还能让孩子通过鼠标点击轻松学习地图。
来看看效果：
用法：
1、可通过三种方式选择要显示的省份，地图上省份所在区域单击、左侧上下箭头按钮、下拉菜单选择省份，地图中对应省份变绿色立体效果并插上小
红旗，同时左侧出现该省的情况简介。
2、通过点击左右箭头按钮，选择要介绍的内容，分三种：情况简介、美食推介、旅游景点。还可继续增加其他内容。
特点：直接在地图上点击即可选中省份显示效果，很便利，适合小孩子们喜欢胡乱点的特性。
家里的小帅哥点到青海时说，好像一只兔子，还别说，青海湖做的兔眼还挺可爱：
陕西的地图有种兵马俑的感觉？
左侧显示的文字介绍数据来源为基础表内容（见下图），可任意扩展。比如修改介绍、增加美食、旅游景点等。也可以修改为地方分公司的指标参数，则秒变公司数据查询表。
实现过程主要分三步：
1、地图制作导入；2、左侧显示框公式设置；3、增加地图选中和变立体变色效果VBA代码。
1、地图制作导入
本图图片文后有提供，只想用本文地图的可跳过直接到下一节。有人想制作省内各市之间的独立地图，首先要在网上找到想要的地图原始图，下载，因后期需要将各省的图单独进行变色编辑，所以插入的图片格式必须为.emf格式。而.svg格式的图片可转换为.emf格式，所以下载时注意需要下载.svg格式的地图。inkscape软件可用于转换，网络搜索下载即可，转换过程很简单，用inkscape软件打开.svg格式文件后，另存为.emf文件即可。
2、左侧显示框公式设置
=OFFSET(Sheet3!B1,MATCH(C2,Sheet3!B2:B35,),B3,1,1)其中C2为上下箭头按钮的指定值区域，B3为左右箭头按钮的值区域。
3、增加地图选中后的立体变色功能
通过设置C2单元格的修改触发代码，进行地图各板块属性设置，小红旗图标根据C2单元格内容移位至对应省区域，同时对右下角标签进行更新。具体过程可参见下面的完整代码。想直接拿到本文表格，欢迎转发留言索取。
主要完整代码：
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row = 2 And Target.Column = 3 Then Call ditu(Target.Value) Call 展示(Target.Value) [a1].Select End If End Sub Private Sub SpinButton1_Change() [c2] = Sheets("sheet3").Cells(SpinButton1.Value + 1, 2) End Sub Sub 北京() ActiveSheet.Shapes.Range(Array("北京")).Select [c2] = Selection.Name End Sub Sub ditu(dm As String) Set jc = Sheets("sheet3") For i = 2 To jc.[b30000].End(3).Row ActiveSheet.Shapes.Range(Array(jc.Cells(i, 2).Value)).Select Selection.ShapeRange.Shadow.Visible = msoFalse Selection.ShapeRange.ThreeD.Visible = msoFalse With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorAccent6 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0.400000006 .Transparency = 0 .Solid End With With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorAccent5 .ForeColor.TintAndShade = -0.5 .ForeColor.Brightness = 0 .Transparency = 0.3 End With With Selection.ShapeRange.Fill .ForeColor.RGB = RGB(100, 200, 200) .Transparency = 0.5 End With Next ActiveSheet.Shapes.Range(Array(dm)).Select Selection.ShapeRange.ShapeStyle = msoShapeStylePreset66 Selection.ShapeRange.Line.Visible = msoFalse Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 255, 0) With Selection.ShapeRange.ThreeD .BevelTopType = msoBevelCircle .BevelTopInset = 6 .BevelTopDepth = 6 End With top1 = Selection.Top + Selection.Height / 4 left1 = Selection.Left + Selection.Width / 2 If Selection.Name = "内蒙古" Then top1 = Selection.Top + Selection.Height / 4 * 2.7 If Selection.Name = "黑龙江" Then top1 = Selection.Top + Selection.Height / 4 * 2 If Selection.Name = "云南" Then top1 = Selection.Top + Selection.Height / 4 * 2 If Selection.Name = "海南" Then top1 = Selection.Top - Selection.Height / 6 If Selection.Name = "陕西" Then top1 = Selection.Top + Selection.Height / 4 * 2 If Selection.Name = "云南" Then top1 = Selection.Top + Selection.Height / 4 * 2 If Selection.Name = "新疆" Then top1 = Selection.Top + Selection.Height / 4 * 2 If Selection.Name = "西藏" Then top1 = Selection.Top + Selection.Height / 4 * 2 ActiveSheet.Shapes.Range(Array("小红旗")).Select Selection.Top = top1 Selection.Left = left1 ActiveSheet.Shapes.Range(Array("五角星")).Top = ActiveSheet.Shapes.Range(Array("北京")).Top ActiveSheet.Shapes.Range(Array("五角星")).Left = ActiveSheet.Shapes.Range(Array("北京")).Left End Sub Sub 展示(dm As String) ActiveSheet.Shapes.Range(Array("展示栏")).Select Set jc = Sheets("sheet3") For i = 2 To jc.[b30000].End(3).Row If jc.Cells(i, 2) = dm Then Exit For End If Next Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = dm End Sub
