爆肝8小时做了一个炫酷图表,Excel 自动播放数据更新条形图制作步骤

那些年一起打过的卡

1、30天玩转数据透视表(已坚持打卡30天)

2、80个必学必会Excel常用函数教程合集(已坚持打卡80天)

3、好看好用的图表52篇（已坚持打卡49天）

4、Excel高效办公技巧52招(已坚持打卡52天)

5、Power Query 15天速成营(已坚持打卡15天)

6、好用的表格模板（已更新93套）

好看好用的图表52篇

第49天自动播放条形图

技巧1：自动播放数据更新条形图制作步骤

练习软件：office Excel 2016

自动播放数据更新条形图

前几天看到一个热搜，说是2023年广东常住人口有1.27亿，连续17年蝉联中国人口大省第一位。刚看到这个新闻小编简直惊掉下巴，印象中人口最多的省份一直都是老家河南。

看了资料才发现，按常住人口统计，2007年广东就超过河南成人口大省了，结合网上爆火的自动播放条形图。

咱们也用Excel条形图+VBA代码做了一个自动播放数据更新的条形图，尽管比着专业工具在效果上差了些，但炫个技Excel技巧还是妥妥的。

颜色不一样的条形图

主题条形图很简单，就是一个普通的条形图，需要调整的地方有两个。

1、选择条形图系列，切换至【填充与线条】选项卡，勾选“依数据点着色”选项，让每个条形的颜色不一样。

2、添加一个文本框，链接到年份数据单元格。

自动更新数据的VBA代码

第一次写这么长的代码，因为条形图是提前做好的，所以代码主要是用来更新数据，应该还有很多可以优化的地方，欢迎大佬批评指正。主要功能点：

1、年份数据加1。

2、提取当前年份和下一年份人口数据，放在第2张工作表C2:D32区域

3、最后一个年份时，下一年度数据置为0，其余年份提取下一年份数据

4、对提取后的数据按人口排名

5、3秒钟更新一次年份数据

6、如果下一年份数据为0，标签数据不更新；如果当前年份人口小于下一年份人口，表示人口增长,标签计数；如果当前年份人口小于下一年份，表示人口减少，标签计数。

Sub broadcast()Worksheets(2).Range("C1") = 2003Do While Worksheets(2).Range("c1") < 2022       Worksheets(2).Range("c1") = Worksheets(2).Range("c1") + 1    Dim row_num_tiqu As Integer    Dim city_match_value As String    Dim year_match_value As Integer    For row_num_tiqu = 2 To 32        city_match_value = Worksheets(2).Cells(row_num_tiqu, 2).Value        year_match_value = Worksheets(2).Cells(1, 3).Value        people_row_num = WorksheetFunction.Match(city_match_value, Worksheets(3).Range("a2:a32"), 0)        people_col_num = WorksheetFunction.Match(year_match_value, Worksheets(3).Range("b1:t1"), 0)        Worksheets(2).Cells(row_num_tiqu, 3) = WorksheetFunction.Index(Worksheets(3).Range("b2:t32"), people_row_num, people_col_num)            If year_match_value < 2022 Then                people_col_num_last = WorksheetFunction.IfNa(WorksheetFunction.Match(year_match_value + 1, Worksheets(3).Range("b1:t1"), 0), 0)                Worksheets(2).Cells(row_num_tiqu, 4) = WorksheetFunction.IfNa(WorksheetFunction.Index(Worksheets(3).Range("b2:t32"), people_row_num, people_col_num_last), 0)            Else                Worksheets(2).Cells(row_num_tiqu, 4) = 0            End If    Next row_num_tiqu    Dim sorted_rng As Range    Set sorted_rng = Worksheets(2).Range("a1:d32")    sorted_rng.Sort key1:="排名", order1:=xlAscending, Header:=xlYes    Range("c2:c32").Copy _                        Destination:=Range("d2")    t = Timer    Do While Timer - t < 3    DoEvents        Dim rng_chart As Range        Dim row_num As Integer        Set rng_chart = Worksheets(1).Range("d2:d32")        row_num = 2        If Worksheets(2).Cells(row_num, 4) <> 0 Then        For Each cell_chart In rng_chart                If (Worksheets(2).Cells(row_num, 3) < Worksheets(2).Cells(row_num, 4) And cell_chart.Value < Worksheets(2).Cells(row_num, 4)) Or _                    (Worksheets(2).Cells(row_num, 3) > Worksheets(2).Cells(row_num, 4) And cell_chart.Value > Worksheets(2).Cells(row_num, 4)) Then                    cell_chart.Value = cell_chart.Value + (Worksheets(2).Cells(row_num, 4) - Worksheets(2).Cells(row_num, 3)) / 100                End If            row_num = row_num + 1        Next cell_chart        End If    LoopLoopEnd Sub