实例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

实例30-工作表中插入多张图片

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