EXCEL过河-全文件夹内xlsx另存为jpg图片

EXCEL过河系列汇总了日常工作中碰到且已经解决的各类EXCEL问题,方法不拘泥于形式但也不具有普适性,权做抛砖引玉

解决实际问题是学习各类工具的最终目的,日常工作中我们碰到的问题多数不是书本中或教程中的常规问题,而往往是各类出乎意料但又意料之中的。

微信/钉钉已经成为众多公司日常工作的一部分,每日往各种群内推送各种报告报表也就成了分析师的日常工作。别以为这类工作只需要拖个excel表进群内就好,相比一个绿色X标志的文件,客户或领导更愿意看到的是直观的图表和间接的报告。这就麻烦了各类分析师们…要知道有的时候我们的报告可能包含多个xlsx文件,每天要不断的把图表复制再粘贴到画图里另存为可是个谁也不愿意干的辛苦活。

那么VBA可不可以搞定呢~?

Sure!

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub 全文件夹另存为图片()
Application.DisplayAlerts = False
Dim myPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择被处理文件的所在文件夹"
If .Show = -1 Then
myPath = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim fs, myfolder, myfile, myfiles
Set fs = CreateObject("Scripting.FileSystemObject")
Set myfolder = fs.GetFolder(myPath)
Set myfiles = myfolder.Files
For Each myfile In myfiles
If myfile.Type = "Microsoft Excel 工作表" Then
Workbooks.Open Filename:=myfile.Path
Dim p, f
Dim x As Range
p = myfolder & "\"
f = ActiveWorkbook.Name
Set x = Range("A2").CurrentRegion
x.Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
With ActiveSheet.ChartObjects.Add(0, 0, x.Width, x.Height)
StartTime = Now()
Do
DoEvents
Loop Until CLng(DateDiff("S", StartTime, Now())) > 1
.Chart.Paste
.Chart.Export Filename:=p & f & ".jpg"
.Chart.Parent.Delete
End With
End If
ActiveWindow.Close
Next
Application.DisplayAlerts = True
End Sub

上述代码将打开所选文件下所有的EXCEL工作表,并将活动sheets的CurrentRegion另存为jpg图片,就放在原文件夹下。

其中循环打开的部分使用了Application.FileDialog(msoFileDialogFolderPicker)和Workbooks.Open 方法

另存为图片部分使用的是.CurrentRegion和一个小技巧:在现有Region上面添加一个同等大小的Chart并另存为jpg

最后的循环DoEvents部分是为了防止速度过快而导出空白图片

记得不可以禁止屏幕更新~如果运行过程出错要使用Application.DisplayAlerts = True恢复提示信息。

OK~Enjoy

本文遵守署名-非营利性使用-相同方式共享协议,转载请保留本段:冰丝带雨 » EXCEL过河-全文件夹内xlsx另存为jpg图片

赞 (1)