Макрос работает только в пошаговом режиме или с одним разрывом в коде, но не при нормальном запуске - PullRequest
Новая
       24

Макрос работает только в пошаговом режиме или с одним разрывом в коде, но не при нормальном запуске

0 голосов
/ 14 сентября 2018

У меня проблема с моим макросом, который создает диаграмму, он хорошо работает, когда я прохожу, но перезапускает мой Excel, когда я запускаю его нормально.Пробовал разные вещи, ничего не работает.Первоначально он был частью другого макроса, но я изолировал его от другого сабвуфера, думая, что он может помочь, но он все равно падает, когда изолирован.

Ребята, вы знаете, что может быть причиной этого?

EDIT1 : информация об ошибке отсутствует, Excel просто перезапускается

EDIT2 : Кажется, проблема связана с этой частью кода: 

    .SetElement (msoElementChartTitleAboveChart)
    .ChartTitle.Text = "Liczba Dni Promocji - Wykres"
    .ChartTitle.Font.Bold = True
    .ChartTitle.Font.Size = 16

Это код: 

Sub StworzWykres()
Application.ScreenUpdating = False
'Application.PrintCommunication = True

Dim ws As Worksheet
Dim pt As PivotTable
Dim chrt As Chart
Dim myRng As Range
Dim i As Integer
Dim j As Integer

Set ws = ThisWorkbook.Sheets("Raport_LiczbaDniPromocji")

Set pt = ws.PivotTables("LDP_Tab1")

'delete existing charts
Dim shp As Shape
For Each shp In ws.Shapes
    shp.Delete
Next shp
Set shp = Nothing

'ask if make a chart
Application.ScreenUpdating = True

If MsgBox("Czy chcesz utworzyć wykres Liczby Dni Promocji?", vbYesNo, "Wykres") = vbNo Then
    Exit Sub
End If

Application.ScreenUpdating = False

'adding the chart
'Set chrt = ws.Shapes.AddChart.Chart
Set myRng = ws.Range(Cells(19 + pt.RowRange.Rows.Count, 4), Cells(18 + 2 * (pt.RowRange.Rows.Count), 6))
myRng.Select
Set chrt = ws.Shapes.AddChart.Chart
'Set chrt = ws.ChartObjects.Add.Chart
'chrt.Activate
With chrt
    'For j = .SeriesCollection.Count To 1 Step -1
    '    .SeriesCollection(j).Delete
    'Next j
    '.SetSourceData Source:=myRng, PlotBy:=xlColumns
    .ChartType = xl3DColumnClustered
    '.SetSourceData Source:=myRng, PlotBy:=xlColumns
    .Parent.Name = "Wykres_LDP"
    .DepthPercent = 400
    .PlotArea.Format.ThreeD.RotationX = 0
    .PlotArea.Format.ThreeD.RotationY = 110
    .RightAngleAxes = True
    .ChartArea.Left = ws.Range(Cells(1, 1), Cells(1, 6)).Width + 1 'ws.Cells(20 + pt.RowRange.Rows.Count, 8).Left - (ws.Columns(7).ColumnWidth / 1.25)
    .ChartArea.Top = ws.Cells(18 + pt.RowRange.Rows.Count, 8).Top
    .ChartArea.Height = ws.Range(Cells(19 + pt.RowRange.Rows.Count, 8), Cells(47 + pt.RowRange.Rows.Count, 8)).Height
    .ChartArea.Width = 1000
    .Parent.Placement = xlMove
    .ChartColor = 10
    .ChartGroups(1).GapWidth = 150
    .SetElement (msoElementLegendBottom)
    .Legend.Font.Size = 12
    .Legend.Font.Bold = True
    .SetElement (msoElementChartTitleAboveChart)
    .ChartTitle.Text = "Liczba Dni Promocji - Wykres"
    .ChartTitle.Font.Bold = True
    .ChartTitle.Font.Size = 16
    With .Axes(xlCategory, xlPrimary)
        .TickLabels.Orientation = 60
        '.TickLabels.Font.Bold = True
        '.TickLabels.Font.Size = 11
    End With
    For j = .SeriesCollection.Count To 1 Step -1
        .SeriesCollection(j).HasDataLabels = True
        .SeriesCollection(j).DataLabels.Orientation = xlUpward
        .SeriesCollection(j).DataLabels.Font.Bold = True
        .SeriesCollection(j).DataLabels.Font.Size = 10
        If j = 1 Then
            .SeriesCollection(j).DataLabels.Font.ColorIndex = 32
        Else
            .SeriesCollection(j).DataLabels.Font.ColorIndex = 46
        End If
    Next j
    '.SetSourceData Source:=myRng, PlotBy:=xlColumns
End With

'clear variables

Set ws = Nothing
Set pt = Nothing
Set myRng = Nothing
i = Empty
j = Empty

'Application.PrintCommunication = False
Application.ScreenUpdating = True
End Sub

1 Ответ

0 голосов
/ 16 сентября 2018

Удалить 

.SetElement (msoElementChartTitleAboveChart)

и вставить 

.HasTitle = True

там же.

...