excel自动生成图表并导出jpg

excelapprentice

附件是手机销售数据表，表中的sheet1是卖场一天的手机销售情况，卖场按照手机品牌的不同分为“苹果”“华为”“小米”等13个部门，现在要将手机销售数据按照部门的不同，筛选出每部门top20，分别制作销售top20图（簇状条形图），然后发送给上级领导。
我之前对excel没有深入了解过，只是简单做个表格会几个简单的函数，所以前述任务处理起来费时费力，一开始是挨个手动出，太费时间。
后来又尝试power quest，先把销售数据表按部门和销售额排序，再用vba分成13个表，然后再删除每个表top20以外的条目，最后用事先做好的模板统一刷新，可以得到想要的图，虽然比之前时间有所短，还是感觉费事，除了事先要先将sheet1总表排序和分解为13个表的必要准备工作之外，主要是手动删除13个部门表的top20以外记录，再手动拷贝每部门的销售图另存为jpg，保存jpg时还要按照命名规则保存，以便整理成pdf时部门排序和公司系统内的部门顺序一致。
再后来，看到有人说用vba，可以实现多张表的情况下，一键出图，而且图片的都是按照既定规则命名的，查了查可能用的是宏，自己试了试，在录制宏后，再执行时，总出错，看代码里的黄色高亮提示，错误可能是改变图表属性（大小、颜色、图例等）或是其他值、以及保存时导致的，上网查也没有头绪，而且好像用宏方式自动生成的图都是excel默认大小，我在录制宏的时候明明是调整过的…
说了这么多，就是想请教大家，怎样可以实现这种一键出图的效果，或者类似的效果，附件是销售情况表，excel大神烦请给出方案。附件说明以及要求如下：
①sheet1是销售数据表，我事先已经把“销售数据表”按部门拆分为13个表，需要实现的是，如何自动拆分sheet1表，筛选出每部门的top20，并且删除掉top20以外的条目（如果不删除也能实现top20图表，那就不用删）
②前几个手机部门的销售top20图已给出了，要求出的簇状条形图大小、颜色和已出的保持一致，并且带图例
③excel表里的条形图的图表标题都统一命名为“XX手机销售top20机型”
④在将top20条形图自动保存（或导出）为jpg格式的图片时，命名规则为“部门代码_XX手机top20“，如“010101_苹果手机top20”
⑤自动保存为jpg格式的图要和excel里的原簇状条形图大小一致

谢谢有耐心的朋友看到这里，再罗嗦两句，我想要的是具体的实现方法，不是给指个方向，不是我不想花时间研究，是每天弄这几个店的图表（除了这个销售数据表，还有其他表也要出具体图表）得耗我几个小时，晚上根本没时间，如果能快速实现图表处理，有时间好好学习下excel，那真是再好不过了。我也为能完全按照要求给出方案的英雄准备了红包，两张红装毛主席吧，微表谢意，注意啊，是微表，觉得太少受到侮辱的请无视，谢谢。

micch

看你的解说确实需要耐心，写的够多的，还没看附件，我觉得设计好表格以后，图表是随着数据更新而更新的，所以一次设计可以一直使用

micch

非常标准的透视表+透视图例子，简单说明一下，根据源直接生成透视表+透视图，透视表筛选选择手机品牌，行用型号，值就是净销售额

然后透视表，可以根据值排序，并且根据值筛选前多少项，这里选择20项。然后透视图自己设计想要的格式。

数据更新的时候，就可以刷新一下。

如果你还是喜欢一个品牌一张表配一张图，可以将生成的表格复制13份也就是了。

附件需要再发，自己尝试一下能做出来就省得我压缩再发了，想录屏可惜肯定超2M大小了


最后补充一句，如果你是要存为图片发送老板看，这一步可以手工完成，拍照13次，当然更可以代码完成。前提是老板不喜欢Excel文件，我觉得Excel文件能互动比图片更好，发Excel文件其实挺好的

micch

给你个代码解决方式的。

Sub savechart()
    arr = Sheet1.UsedRange
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If arr(i, 3) <> "" Then
            x = arr(i, 3) & " " & arr(i, 4)
            If Not d.exists(x) Then Set d(x) = CreateObject("scripting.dictionary")
            d(x)(arr(i, 6)) = d(x)(arr(i, 6)) + arr(i, 7)
        End If
    Next
    With Sheets("苹果")
        Set cht = .ChartObjects(1)
        For Each x In d.keys
            .[f2:g21].ClearContents
            .[f2].Resize(d(x).Count, 2) = Application.Transpose(Array(d(x).keys, d(x).items))
            .[f2].Resize(d(x).Count, 2).Sort .[g2], 2
            cht.Chart.SetSourceData Source:=.[f1].Resize(IIf(d(x).Count > 20, 21, d(x).Count + 1), 2)
            cht.Chart.ChartTitle.Text = Split(x)(1) & "手机销售TOP20机型"
            myname$ = ThisWorkbook.Path & "\" & Split(x)(0) & "_" & Split(x)(1) & "TOP20.jpeg"
            cht.Chart.Export Filename:=myname, FilterName:="jpeg"
        Next
    End With
End Sub

excelapprentice

首先，非常感谢，我不懂代码，所以还得问详细些
①您给的这段代码是否需要提前把sheet1表拆分为13个表？我直接在vba运行环境下执行，报错，“运行时错误9：下表越界”
②如果需要先把表拆分为13个表，那么拆解的代码和您给的这段代码应该怎么组合，才能实现自动导出条形图片的效果？
③With Sheets("苹果") ……end with，每个手机都需要这么一段代码吗？程序没法执行，我看不出执行效果
附件压缩包包括两部分，txt文档是我之前从网上找的拆分表的代码，压缩包是我之前看的一个网友的例子，我要的是这种效果，您看一下是否能够实现

excelapprentice

micch 发表于 2020-1-15 21:17
非常标准的透视表+透视图例子，简单说明一下，根据源直接生成透视表+透视图，透视表筛选选择手机品牌， ...

领导不看excel表的，如果直接给他excel可以的话，就不用我又是导出图，又是整理成pdf文档了，拍照的方式不可取，你说的这种透视图表的这种方法，效率可能和我目前用power quest差不多，直接生成图标并要求大小导出为jpg的这种方式效率更高，我还是倾向于vba代码方式，无奈没基础，哎

excelapprentice

micch 发表于 2020-1-15 23:11
给你个代码解决方式的。

Sub savechart()

代码这种方式我试了一下，有些疑问，见5楼

micch

因为你要的是图片，所以就不需要13个表了，13个图都在苹果表里循环了，循环一次就把对应手机的数据输出到FG列，然后把条形图输出一张图片，如果你还是要13个工作表并且附带13个条形图，然后再输出13个图片，那就太麻烦了，晚上的火车怕是没时间给你改了，直接给你个附件自己先琢磨的改下吧
没个手机一份数据，存在字典里，for循环的时候，循环一次生成一个表一个图，如果你希望是13个表，可以在循环的过程中加入语句，可以直接copy苹果表，然后数据覆盖一下


手机销售数据.zip (183.27 KB, 下载次数: 55)

2020-1-16 16:44 上传

点击文件名下载附件

micch

修改一下，生成13个表，输出13个图，条形图直接用苹果表做模板

1. Sub savechart()
   
2.     arr = Sheet1.UsedRange
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i% = 2 To UBound(arr)
   
5.         If arr(i, 3) <> "" Then d(arr(i, 3) & "" & arr(i, 4)) = d(arr(i, 3) & "" & arr(i, 4)) & " " & i
   
6.     Next i
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.     For Each sht In Sheets
   
10.         If sht.Name <> "Sheet1" And sht.Name <> "苹果" Then sht.Delete
    
11.     Next
    
12.     Set sht = Sheets("苹果")
    
13.     For Each x In d.keys
    
14.         ar = Split(d(x))
    
15.         ReDim brr(1 To UBound(ar), 1 To 9)
    
16.         With sht
    
17.             .[a2:k222].ClearContents
    
18.             For i = 1 To UBound(ar)
    
19.             For k% = 1 To 9
    
20.                 brr(i, k) = arr(ar(i), k)
    
21.             Next k, i
    
22.             .[a2].Resize(i - 1, 9) = brr
    
23.             .[a2].Resize(i - 1, 9).Sort .[g2], 2
    
24.             .[a2].Offset(IIf(i > 20, 20, i)).Resize(99, 9).ClearContents
    
25.             Set cht = .ChartObjects(1)
    
26.             cht.Chart.SetSourceData Source:=.[f1].Resize(IIf(i > 20, 21, i), 2)
    
27.             cht.Chart.ChartTitle.Text = .[d2] & "手机销售TOP20机型"
    
28.             myname$ = ThisWorkbook.Path & "" & .[c2] & "_" & .[d2] & "TOP20.jpeg"
    
29.             cht.Chart.Export Filename:=myname, FilterName:="jpeg"
    
30.             If .[d2].Value = "苹果" Then
    
31.                 crr = .[a2:k21]
    
32.             Else
    
33.                 sht.Copy after:=Sheets(Sheets.Count)
    
34.                 Sheets(Sheets.Count).Name = sht.[d2]
    
35.             End If
    
36.         End With
    
37.     Next
    
38.     sht.[a2:k21] = crr
    
39.     Application.ScreenUpdating = True
    
40.     Application.DisplayAlerts = True
    
41. End Sub

复制代码

excelapprentice

micch 发表于 2020-1-17 14:19
修改一下，生成13个表，输出13个图，条形图直接用苹果表做模板

非常感谢非常感谢
这个我明天试试，今天太晚了，另外，分解成13个表这一步不是必要的，我最终要的是图