最近新型肺炎肆虐，牵动全国人民的心，全国人民都在密切关注着疫情。各大媒体平台相继上线了疫情相关的实时页面，方便民众随时了解最新动态。
下图是百度疫情实时大数据报告。
为了反映1月20号至今的疫情演变情况，我制作了一个excel版本的动态疫情地图：
演示效果：
播放
暂停
进入全屏
退出全屏
00:00
00:00
重播
请
刷新
试试案例数据来源： 百度疫情实时大数据
https://voice.baidu.com/act/newpneumonia/newpneumonia
（视频演示的数据截止至1-31 18:25）
制作方法：
1、设置颜色和数据区间
【Sheet1】
J列：填充颜色
K列：对应数据区间
L、M列：辅助列（确定区间最值）
O列：省份名称
P列：各省确诊人数 （P2公式：=IFERROR(VLOOKUP($O2,数据源!$B$3:$ZZ$36,数据源!$A$1,FALSE),0)）
S列：全国确诊人数（S2公式：=IFERROR(VLOOKUP($R2,数据源!$B$37:$ZZ$37,数据源!$A$1,FALSE),)）
2、插入条形图
选择R2:S2,插入柱形图，调整位置，删除坐标轴、系列，修改标题
3、粘贴数据
从百度复制粘贴的数据如下，A、B两列粘贴数值到【数据源】B2单元格
4.【数据源】整理如下
【Sheet2】更改表名为 【数据源 】
A1:=Sheet1!E5-DATE(2020,1,20)+2
B1:=IF(B2="","",COLUMN()-1)，
C37:=SUM(C3:C36)
5.Alt+F11,插入模块
<code>
Sub
可视化()
Dim
M As Integer '颜色行数
Dim
Rng As Range '确诊数据
Dim
i As Integer '数据变量
For
Each Rng In Sheet1.Range("p2:p35")
For
i = 13 To 20
If
Rng.Value >= Sheet1.Range("l" & i) And Rng.Value < Sheet1.Range("m" & i) Then '确认确诊数量档位
M
=i '确认颜色行数
Exit
For
End
If
Next
If
Sheet1.Shapes(Rng.Offset(0, -1).Value).Fill.ForeColor.RGB <> Cells(M, "j").Interior.Color Then
-1).Value).Fill.ForeColor.RGB = Cells(M, "j").Interior.Color '填色
-1).Value).TextFrame2.TextRange.Characters.Text = Rng.Offset(0, -1).Value & Chr(10) & Rng.Value '区块省份名称+人数
-1).Value).TextFrame2.TextRange.Font.Size = 6 '设置字体大小
a
=0 '延时
t
=Timer
Do
While a < 0.13 '延时参数，数值越大，延时越长【自行修改测试】
a
=Timer - t
DoEvents
Loop
Else
-1).Value).TextFrame2.TextRange.Characters.Text = Rng.Offset(0, -1).Value & Chr(10) & Rng.Value '区块省份名称+人数
End
If
Next
End
Sub
Sub
演示()
Call
重置颜色 '调用
="2020-1-20" '设置初始值
a
=0 '延时
t
=Timer
Do
While a < 1 '延时参数
a
=Timer - t
DoEvents
Loop
For
i = 1 To Sheet2.Range("a1").End(xlToRight).Value - 2
Call
可视化
=Sheet1.Range("e5").Value + 1
Next
Call
可视化
End
Sub
Sub
重置颜色()
For
Each Rng In Sheet1.Range("o2:o35")
=Cells(13, "j").Interior.Color '填色
=Rng.Value '省名称+人数
Next
=""
End
Sub
/<code>6.插入图形 ，指定宏
完毕！
源文件下载地址：
https://shimo.im/docs/h3VxxXTpjKDvhjH6/ 《头条号文章〈Excel动态实时新冠肺炎感染确诊地图〉源文件》，可复制链接后用石墨文档 App 或小程序打开
最后：愿每个人都积极防护，身体健康！