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中.....?
求高人指点

7 个解决方案

#1

Sub CopySheet()

If IsWbOpen("Temp.xls") Then
    ActiveSheet.Copy Before:=Workbooks("Temp.xls").Sheets(1)
Else
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:="Temp.xls", FileFormat:=xlNormal
End If

End Sub

如果temp.xls在打开状态, 那么把当前sheet拷入temp.xls第一页中, 如果不在打开状态, 那么这个sheet存成temp.xls
是这个意思不

#2

不是，现在有一个EXCEL(A)文件,当打开excel时候自动执行上面的VBA,现在上面的是把数据和图表插入到新创建的EXCEL(B00K1)中的worksheet中,我想实现他把数据和图表插入到EXCEL(A)的新sheet中.

#3

直接把要创建图表的sheet赋给  objWorksheet   应该可以！

#4

怎么写啊，我不会写 另外 如果我换一个图表类型（柱图）因该怎么写？

就是类似数据分析里面直方图的输出图表的 效果，恳求各位赏段代码

#5

Set objExcel = CreateObject("Excel.Application")
      objExcel.Visible = True
      Set objWorkbook = objExcel.Workbooks.Add()
      Set objWorksheet = objWorkbook.Worksheets(1)
这段代码改为删除，所有的 objWorksheet改为ActiveSheet

#6

或把Set objExcel = CreateObject("Excel.Application")
      objExcel.Visible = True
      Set objWorkbook = objExcel.Workbooks.Add()
删除
并且把Set objWorkbook = objExcel.Workbooks.Add()
改为：Set objExcel = ActiveSheet

#7

谢谢结帐