Excel動態實時新冠肺炎感染確診地圖（隨附件下載）頭條網

Excel動態實時新冠肺炎感染確診地圖（隨附件下載）

2021-04-08 17:54:50 佚名

最近新型肺炎肆虐，牽動全國人民的心，全國人民都在密切關注著疫情。各大媒體平臺相繼上線了疫情相關的實時頁面，方便民眾隨時瞭解最新動態。

下圖是百度疫情實時大數據報告。

為了反映1月20號至今的疫情演變情況，我製作了一個excel版本的動態疫情地圖：

演示效果：

播放

暫停

進入全屏

退出全屏

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>