- Код: Выделить всё
Sub CreateDiagram()
Clipboard.Clear 'очищаем буфер обмена
Set EApp = New Excel.Application
Set EWB = EApp.Workbooks.Open(App.Path & "\" & "file.xls")
Set EWSH = EWB.Worksheets.Add
'EApp.Visible = True
With EWSH
.Cells(1, 1).Value = "Справились" 'это для подписи в легенде
.Cells(2, 1).Value = "Не справились" 'это для подписи в легенде
.Cells(1, 2).Value = txtBad.Text 'первое значение
.Cells(2, 2).Value = txtGood.Text 'второе значение
End With
With EWB
.Charts.Add
.ActiveChart.ChartType = xl3DPie
.ActiveChart.SetSourceData Source:=Sheets(EWSH.Name).Range("A1:B2"), PlotBy:= _
xlColumns
' при повторной попытке построить диаграмму почему-то
'подпрограмма прерывается сдесь и не выполняет все ниже 'идущие операторы, а следовательно диаграмма не копируется
.ActiveChart.Location Where:=xlLocationAsObject, Name:=EWSH.Name
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Название диаграммы"
End With
.ActiveChart.SeriesCollection(1).Select
.ActiveChart.SeriesCollection(1).ApplyDataLabels Type:=xlDataLabelsShowPercent _
, AutoText:=True, LegendKey:=False, HasLeaderLines:=True
.ActiveChart.PlotArea.Select
With Selection.Border
.Weight = xlHairline
.LineStyle = xlNone
End With
With Selection.Interior
.ColorIndex = 2
.PatternColorIndex = 1
.Pattern = xlSolid
End With
.ActiveChart.ChartArea.Select
.ActiveChart.ChartArea.Copy
End With
'всё закрываем
EWB.Close False
EApp.Quit
Set EWSH = Nothing
Set EWB = Nothing
Set EApp = Nothing
End Sub
P.S. что-то я вообще не понял с какого перепуга подпрограмма обрывается в середине выполнения...
