作者：绿色风
分类：
时间：2022-08-17
浏览：117
楼主
kevinchengcw |
Q: 如何用vba代码将横向数据排序后将不同区域转换成图片存放？
A: 示例代码如下:- Sub test()
- Dim Dic As Object, N&, I&, T&, Str$, Arr
- On Error Resume Next '设置容错,防止程序卡住
- Application.ScreenUpdating = False '涉及到大量的单元格操作,关闭屏幕刷新提高运行速度
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- T = 2 '初始化数据列的起始列号
- For N = T To Cells(1, Columns.Count).End(1).Column '循环数据区各列
- Str = Cells(1, N).Value '将首行内容赋值给变量
- If Str <> "" Then '如果单元格内容不为空则执行下述语句
- If Dic.exists(Str) Then '如果该值已经在字典中存在,则
- If N - Val(Dic(Str)) > 1 Then '如果当前列与已存在的列号差值大于1(即不相邻的情况),则
- Columns(N).Cut '当前列剪切
- Columns(Val(Dic(Str)) + 1).Insert '插入到字典中存的列的后一列(即将相同的内容移动到一起的过程)
- Dic(Str) = Val(Dic(Str)) + 1 '字典对应项目的所存列号加1
- Else
- Dic(Str) = N '如果与所存值相邻,则更新为当前列的列值
- End If
- Else
- Dic.Add Str, N '如果字典中不存在该值,则添加
- End If
- End If
- Next N
- Arr = Dic.items '将所存的列号值赋值给数组
- I = Cells(Rows.Count, 1).End(3).Row '取得数据区行最大值
- For N = LBound(Arr) To UBound(Arr) '循环数组各个值(即每个不同类型数据对应数据区列号的最大值)
- Range(Cells(1, T), Cells(I, Val(Arr(N)))).Select '选择当前循环到的数据区
- Selection.CopyPicture '选区复制为图片
- With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart '通过在当前工作表添加相同大小的图表的方式转存成图片(也可以通过固定一个图表通过调整大小来中转)
- .Paste '粘贴复制后的图片
- .Export ThisWorkbook.Path & "\" & Cells(1, T).Value & ".jpg", "jpg" '导出到当前工作表目录下,以当前区域首行单元格的值命名图片
- .Parent.Delete '删除该图表
- End With
- T = Val(Arr(N)) + 1 '数据区起始列号转成下一个数据区域起始列号
- Next N
- Set Dic = Nothing '清空字典项目
- Application.ScreenUpdating = True '打开屏幕刷新
- MsgBox "Finished!" '显示提示信息
- End Sub
详见素材源帖:
http://www.exceltip.net/thread-21110-1-1.html
 示例文件.rar
|
2楼
清华 |
真棒
 |
3楼
tieqilin |
太好了，那哈哈哈哈水星家纺 |
4楼
huhaifeng |
太棒了 |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一