excel vba 怎么样将自动生成图表并将其添加到已有的EXCEL中
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim temp As Long
Dim r As Long
Dim a As String
Dim result() As Long
ReDim result(10)
Dim range() As Long
ReDim range(10)
range(0) = 0
For r = 1 To 10 Step 1
range(r) = range(r - 1) + 2000:
Next r
For r = 9 To 44 Step 1
a = CStr(UCase(Cells(r, 2).Value))
temp = Val(a)
If temp > = range(0) And temp < range(1) Then result(0) = result(0) + 1
If temp > = range(1) And temp < range(2) Then result(1) = result(1) + 1
If temp > = range(2) And temp < range(3) Then result(2) = result(2) + 1
If temp > = range(3) And temp < range(4) Then result(3) = result(3) + 1
If temp > = range(4) And temp < range(5) Then result(4) = result(4) + 1
If temp > = range(5) And temp < range(6) Then result(5) = result(5) + 1
If temp > = range(6) And temp < range(7) Then result(6) = result(6) + 1
If temp > = range(7) And temp < range(8) Then result(7) = result(7) + 1
If temp > = range(8) And temp < range(9) Then result(8) = result(8) + 1
If temp > = range(9) And temp < range(10) Then result(9) = result(9) + 1
If temp > = range(10) Then result(10) = result(10) + 1
Next r
For r = 0 To 10 Step 1
a = CStr(result(r))
Next r
----------------------------------
Dim colCharts As Object
Const xlDataLabelsShowPercent = 3
Set objExcel = CreateObject( "Excel.Application ")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
Set objWorksheet = objWorkbook.Worksheets(1)
----------------------------------
objWorksheet.Cells(1, 1) = "分类 "
objWorksheet.Cells(2, 1) = "0 <=x <2000 "
objWorksheet.Cells(3, 1) = "2000 <=x <4000 "
objWorksheet.Cells(4, 1) = "4000 <=x <6000 "
objWorksheet.Cells(5, 1) = "6000 <=x <8000 "
objWorksheet.Cells(6, 1) = "8000 <=x <10000 "
objWorksheet.Cells(7, 1) = "10000 <=x <12000 "
objWorksheet.Cells(8, 1) = "12000 <=x <14000 "
objWorksheet.Cells(9, 1) = "14000 <=x <16000 "
objWorksheet.Cells(10, 1) = "16000 <=x <18000 "
objWorksheet.Cells(11, 1) = "18000 <=x <20000 "
objWorksheet.Cells(12, 1) = "x> =20000 "
objWorksheet.Cells(1, 2) = "分地区按总计直方图 "
objWorksheet.Cells(2, 2) = result(0)
objWorksheet.Cells(3, 2) = result(1)
objWorksheet.Cells(4, 2) = result(2)
objWorksheet.Cells(5, 2) = result(3)
objWorksheet.Cells(6, 2) = result(4)
objWorksheet.Cells(7, 2) = result(5)
objWorksheet.Cells(8, 2) = result(6)
objWorksheet.Cells(9, 2) = result(7)
objWorksheet.Cells(10, 2) = result(8)
objWorksheet.Cells(11, 2) = result(9)
objWorksheet.Cells(12, 2) = result(10)
Set objRange = objWorksheet.UsedRange
objRange.Select
Set colCharts = objExcel.Charts
colCharts.Add
Set objChart = colCharts(1)
objChart.Activate
objChart.ChartType = 70
objChart.Elevation = 30
objChart.Rotation = 80
objChart.ApplyDataLabels xlDataLabelsShowPercent
objChart.PlotArea.Fill.Visible = False
objChart.PlotArea.Border.LineStyle = -4142
objChart.SeriesCollection(1).DataLabels.Font.Size = 14
objChart.SeriesCollection(1).DataLabels.Font.ColorIndex = 2
objChart.ChartArea.Fill.ForeColor.SchemeColor = 49
objChart.ChartArea.Fill.BackColor.SchemeColor = 23
objChart.ChartArea.Fill.TwoColorGradient 1, 1
objChart.ChartTitle.Font.Size = 24
objChart.ChartTitle.Font.ColorIndex = 2
objChart.Legend.Shadow = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
怎么样用VBA将生成的EXCEL图表和表格,装在指定的已存在的EXCEL中.....?
求高人指点
[解决办法]
直接把要创建图表的sheet赋给 objWorksheet 应该可以！
[解决办法]
或把Set objExcel = CreateObject( "Excel.Application ")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
删除
并且把Set objWorkbook = objExcel.Workbooks.Add()
改为：Set objExcel = ActiveSheet
