实例29-多个工作表添加图表
Private Sub CommandButton生成_Click()
'判断工作簿名，文件夹地址不为空
(资料图片仅供参考)
With ThisWorkbook.Worksheets("操作界面")
If Trim(.Cells(2, "C").Value) = "" Or Trim(.Cells(6, "C").Value) = "" Or Trim(.Cells(10, "C").Value) = "" Then
MsgBox "参数不能为空"
Exit Sub
End If
On Error GoTo 处理出错
'定义变量
Dim wbname As String
wbname = Trim(.Cells(2, "C").Value)
Dim datarange As String
datarange = Trim(.Cells(6, "C").Value)
Dim chartposition As String
chartposition = Trim(.Cells(10, "C").Value)
End With
'复制图表
ThisWorkbook.Worksheets("模板").ChartObjects(1).Activate
ActiveChart.ChartArea.Copy
'处理表格
With Workbooks(wbname)
'循环判断
Dim i
For i = 1 To .Worksheets.Count
With .Worksheets(i)
'插入图表
.Activate
.Range(chartposition).Select
.Paste
.ChartObjects(.ChartObjects.Count).Activate
ActiveChart.SetSourceData Source:=.Range(datarange)
End With
Next i
.Save
End With
MsgBox "处理完成"
Exit Sub
处理出错:
MsgBox Err.Description
End Sub
Private Sub CommandButton处理_Click()
'判断工作簿名，工作表名不为空
With ThisWorkbook.Worksheets("操作界面")
If Trim(.Cells(2, "C").Value) = "" Or Trim(.Cells(6, "C").Value) = "" Then
MsgBox "参数不能为空"
Exit Sub
End If
'On Error GoTo 处理出错
'定义变量
Dim wbname As String
Dim shname As String
wbname = Trim(.Cells(2, "C").Value)
shname = Trim(.Cells(6, "C").Value)
Dim imax As Long
imax = ThisWorkbook.Worksheets("参数列表").Cells(1000000, 1).End(xlUp).Row
End With
'处理表格
With Workbooks(wbname).Worksheets(shname)
'循环判断（反向）
Dim i
Dim picposition As String
Dim picpath As String
Dim picheight As Long
For i = 1 To imax
picposition = ThisWorkbook.Worksheets("参数列表").Cells(i, 1)
picpath = ThisWorkbook.Worksheets("参数列表").Cells(i, 2)
picheight = ThisWorkbook.Worksheets("参数列表").Cells(i, 3)
If picposition <> "" And picpath <> "" And picheight <> 0 Then
.Shapes.AddPicture picpath, 0, True, .Range(picposition).Left, .Range(picposition).Top, -1, -1
.Shapes(.Shapes.Count).LockAspectRatio = msoTrue
.Shapes(.Shapes.Count).Height = picheight
End If
Next i
End With
Workbooks(wbname).Save
MsgBox "处理完成"
Workbooks(wbname).Activate
ActiveWindow.WindowState = xlMaximized
Workbooks(wbname).Worksheets(shname).Activate
Workbooks(wbname).Worksheets(shname).Cells(1, 1).Select
Exit Sub
处理出错:
MsgBox Err.Description
End Sub