如果条件，VBA Powerpoint脚本将终止

Question

我在Powerpoint文件中有一个非常长的宏脚本，但如果匹配一个if-case，则调用另一个过程。

如果未调用该过程，则脚本运行完美平滑，但如果满足条件，则脚本不会继续。它在被叫程序＆＃34; zusatzseite＆＃34;

之后终止

部分代码：

If d = 1 And StrComp(wsheet.Cells((68 + (3 * rows)), 1), vbatextcompare) <> 0 
   Then Call zusatzseite

我很确定其他代码是好的，因为当没有调用此方法时脚本不会取消。

也许它太长了？如果有人能帮助我会很棒。

编辑：

Sub zusatzseite()
s = s + 1 'nächste Powerpointseite
PP.Slides.Add s, ppLayoutBlank


Call rahmen


'Tabelle einfügen
Set pptshape = PP.Slides(s).Shapes.AddTable(21, 16, 5, 60, 775, 400)
'Tabelle Rahmen formatieren
For i3 = 1 To 21
For i4 = 1 To 16
pptshape.Table.Cell(i3, i4).Borders(ppBorderBottom).ForeColor.RGB = RGB(0, 0, 0)
pptshape.Table.Cell(i3, i4).Borders(ppBorderBottom).Weight = 0.5
pptshape.Table.Cell(i3, i4).Borders(ppBorderTop).ForeColor.RGB = RGB(0, 0, 0)
pptshape.Table.Cell(i3, i4).Borders(ppBorderTop).Weight = 0.5
pptshape.Table.Cell(i3, i4).Borders(ppBorderLeft).ForeColor.RGB = RGB(0, 0, 0)
pptshape.Table.Cell(i3, i4).Borders(ppBorderLeft).Weight = 0.5
pptshape.Table.Cell(i3, i4).Borders(ppBorderRight).ForeColor.RGB = RGB(0, 0, 0)
pptshape.Table.Cell(i3, i4).Borders(ppBorderRight).Weight = 0.5
pptshape.Table.Cell(i3, i4).Shape.TextFrame.TextRange.Font.Size = 12
pptshape.Table.Cell(i3, i4).Shape.TextFrame.TextRange.Font.Bold = False
pptshape.Table.Cell(i3, i4).Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
pptshape.Table.Cell(i3, i4).Shape.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)
pptshape.Table.Cell(i3, i4).Shape.TextFrame.MarginLeft = 3
pptshape.Table.Cell(i3, i4).Shape.TextFrame.MarginRight = 3
pptshape.Table.Cell(i3, i4).Shape.TextFrame.MarginBottom = 1
pptshape.Table.Cell(i3, i4).Shape.TextFrame.MarginTop = 1
Next i4
Next i3
'Rahmen links weg und Zellhöhe anpassen
For i3 = 1 To 21
pptshape.Table.Cell(i3, 1).Borders(ppBorderLeft).ForeColor.RGB = RGB(255, 255, 255)
pptshape.Table.rows.Item(i3).Height = 16
Next i3
'Rahmen rechts weg
For i3 = 1 To 21
pptshape.Table.Cell(i3, 16).Borders(ppBorderRight).ForeColor.RGB = RGB(255, 255, 255)
Next i3
'Rahmen oben weg
For i3 = 1 To 16
pptshape.Table.Cell(1, i3).Borders(ppBorderTop).ForeColor.RGB = RGB(255, 255, 255)
Next i3
'Rahmen unten weg
For i3 = 1 To 16
pptshape.Table.Cell(21, i3).Borders(ppBorderBottom).ForeColor.RGB = RGB(255, 255, 255)
Next i3
'Tabelle Kopfzeile befüllen
pptshape.Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = "No."
pptshape.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = "Aufgabe/ Meilenstein"
pptshape.Table.Cell(1, 3).Shape.TextFrame.TextRange.Text = "Jan"
pptshape.Table.Cell(1, 4).Shape.TextFrame.TextRange.Text = "Feb"
pptshape.Table.Cell(1, 5).Shape.TextFrame.TextRange.Text = "Mrz"
pptshape.Table.Cell(1, 6).Shape.TextFrame.TextRange.Text = "Apr"
pptshape.Table.Cell(1, 7).Shape.TextFrame.TextRange.Text = "Mai"
pptshape.Table.Cell(1, 8).Shape.TextFrame.TextRange.Text = "Jun"
pptshape.Table.Cell(1, 9).Shape.TextFrame.TextRange.Text = "Jul"
pptshape.Table.Cell(1, 10).Shape.TextFrame.TextRange.Text = "Aug"
pptshape.Table.Cell(1, 11).Shape.TextFrame.TextRange.Text = "Sep"
pptshape.Table.Cell(1, 12).Shape.TextFrame.TextRange.Text = "Okt"
pptshape.Table.Cell(1, 13).Shape.TextFrame.TextRange.Text = "Nov"
pptshape.Table.Cell(1, 14).Shape.TextFrame.TextRange.Text = "Dez"
pptshape.Table.Cell(1, 15).Shape.TextFrame.TextRange.Text = "Verantwortlich"
pptshape.Table.Cell(1, 16).Shape.TextFrame.TextRange.Text = "Status"
'Tabelle Spaltenbreite anpassen
pptshape.Table.Columns.Item(1).Width = 41
pptshape.Table.Columns.Item(2).Width = 230
For i3 = 3 To 14
pptshape.Table.Columns.Item(i3).Width = 26
Next i3
pptshape.Table.Columns.Item(15).Width = 120
pptshape.Table.Columns.Item(16).Width = 70
'Tabelle Grauer Hintergrund
For i3 = 1 To 16
pptshape.Table.Cell(1, i3).Shape.Fill.ForeColor.RGB = RGB(220, 230, 242)
Next i3
'Tabelle befüllen
'Nummer
For i3 = 0 To 18
pptshape.Table.Cell(i3 + 2, 1).Shape.TextFrame.TextRange.Text = wsheet.Cells(68 + (3 * (rows - 1 + i3)), 1).Value
Next i3
'Beschreibung
For i3 = 0 To 18
pptshape.Table.Cell(i3 + 2, 2).Shape.TextFrame.TextRange.Text = wsheet.Cells(68 + (3 * (rows - 1 + i3)), 3).Value
Next i3
'Monate
For i4 = 0 To 11
For i3 = 0 To 18
pptshape.Table.Cell(i3 + 2, 3 + i4).Shape.TextFrame.TextRange.Text = wsheet.Cells(68 + (3 * (rows - 1 + i3)), 41 + (2 * i4)).Value
r = getR(wsheet.Cells(68 + (3 * (rows - 1 + i3)), 41 + (2 * i4)))
g = getG(wsheet.Cells(68 + (3 * (rows - 1 + i3)), 41 + (2 * i4)))
b = getB(wsheet.Cells(68 + (3 * (rows - 1 + i3)), 41 + (2 * i4)))
pptshape.Table.Cell(i3 + 2, 3 + (rows - 1 + i3)).Shape.Fill.ForeColor.RGB = RGB(r, g, b)
Next i3
Next i4
'Verantwortlicher
For i3 = 0 To 18
pptshape.Table.Cell(i3 + 2, 15).Shape.TextFrame.TextRange.Text = wsheet.Cells(68 + (3 * (rows - 1 + i3)), 17).Value
Next i3
'Status
For i3 = 0 To 18
pptshape.Table.Cell(i3 + 2, 16).Shape.TextFrame.TextRange.Text = wsheet.Cells(68 + (3 * (rows - 1 + i3)), 38).Value
If StrComp(wsheet.Cells(68 + (3 * (rows - 1 + i3)), 38).Value, "offen") = 0 Then
pptshape.Table.Cell(i3 + 2, 16).Shape.Fill.ForeColor.RGB = RGB(255, 0, 0)
pptshape.Table.Cell(i3 + 2, 16).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 199, 206)
End If
If StrComp(wsheet.Cells(68 + (3 * (rows - 1 + i3)), 38).Value, "laufend") = 0 Then
pptshape.Table.Cell(i3 + 2, 16).Shape.Fill.ForeColor.RGB = RGB(255, 235, 156)
pptshape.Table.Cell(i3 + 2, 16).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 102, 0)
End If
If StrComp(wsheet.Cells(68 + (3 * (rows - 1 + i3)), 38).Value, "erledigt") = 0 Then
pptshape.Table.Cell(i3 + 2, 16).Shape.Fill.ForeColor.RGB = RGB(198, 239, 206)
pptshape.Table.Cell(i3 + 2, 16).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(0, 176, 80)
End If
Next i3
'Auf Länge Prüfen
z = 0
For i3 = 1 To 21
z = z + pptshape.Table.rows.Item(i3).Height
Next i3
'kürzen so lange bis 444 pixel Höhe
i3 = 21
Do Until z < 444
If z > 443 Then d = 1
z = z - pptshape.Table.rows.Item(i3).Height
pptshape.Table.rows.Item(i3).Delete
i3 = i3 - 1
Loop
End Sub