實(shí)例29-多個(gè)工作表添加圖表

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 "參數(shù)不能為空"

Exit Sub

End If

On Error GoTo 處理出錯(cuò)

'定義變量

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

'復(fù)制圖表

ThisWorkbook.Worksheets("模板").ChartObjects(1).Activate

ActiveChart.ChartArea.Copy

'處理表格

With Workbooks(wbname)

'循環(huán)判斷

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

處理出錯(cuò):

MsgBox Err.Description

End Sub

實(shí)例30-工作表中插入多張圖片

Private Sub CommandButton處理_Click()

'判斷工作簿名，工作表名不為空

With ThisWorkbook.Worksheets("操作界面")

If Trim(.Cells(2, "C").Value) = "" Or Trim(.Cells(6, "C").Value) = "" Then

MsgBox "參數(shù)不能為空"

Exit Sub

End If

'On Error GoTo 處理出錯(cuò)

'定義變量

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("參數(shù)列表").Cells(1000000, 1).End(xlUp).Row

End With

'處理表格

With Workbooks(wbname).Worksheets(shname)

'循環(huán)判斷（反向）

Dim i

Dim picposition As String

Dim picpath As String

Dim picheight As Long

For i = 1 To imax

picposition = ThisWorkbook.Worksheets("參數(shù)列表").Cells(i, 1)

picpath = ThisWorkbook.Worksheets("參數(shù)列表").Cells(i, 2)

picheight = ThisWorkbook.Worksheets("參數(shù)列表").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

處理出錯(cuò):

MsgBox Err.Description

End Sub