此代码是查找并替换文本列表以进行质量检查

sub FindAndReplace()
 Dim Pres As Presentation
 Dim sld As Slide
 Dim shp As Shape

 For Each Pres In Application.Presentations
      For Each sld In Pres.Slides
         For Each shp In sld.Shapes
             Call checklist(shp)
         Next shp
     Next sld
 Next Pres
 MsgBox "Completed Succesfully!"
 End Sub

Sub checklist(shp As Object)

    Dim txtRng As TextRange
    Dim rngFound As TextRange
    Dim I, K, X As Long
    Dim iRows As Integer
    Dim iCols As Integer
    Dim TargetList, DestinationList

    TargetList = Array("        ", "       ", "      ", "     ", "    ", "   ", "  ", " / ", "i.e. ", "e.g. ", "/ ", " /", " :", " ;", " .", " ,", " - ", "resume", "a.m.", "p.m.", ":00")
    DestinationList = Array(" ", " ", " ", " ", " ", " ", " ", "/", "i.e., ", "e.g., ", "/", "/", ":", ";", ".", ",", " – ", "résumé", "am", "")


       With shp

       If shp.HasTable Then
       For iRows = 1 To shp.Table.Rows.Count
                    For iCols = 1 To shp.Table.Rows(iRows).Cells.Count
                        Set txtRng = shp.Table.Rows(iRows).Cells(iCols).Shape.TextFrame.TextRange
                               For I = 0 To UBound(TargetList)
                               Set rngFound = txtRng.Replace(TargetList(I), DestinationList(I))
                               Do While Not rngFound Is Nothing
                               Set rngFound = txtRng.Replace(TargetList(I), DestinationList(I), After:=rngFound.Start + rngFound.Length, wholewords:=True)
                               Loop
                               Next
                        Next
                Next
       End If

     End With


           Select Case shp.Type


            Case msoGroup
                For X = 1 To shp.GroupItems.Count
                    Call checklist(shp.GroupItems(X))
                Next X

            Case 21
                For X = 1 To shp.Diagram.Nodes.Count
                    Call checklist(shp.GroupItems(X))
                Next X

            Case Else

                 If shp.HasTextFrame Then
                           If shp.TextFrame.HasText Then
                               Set txtRng = shp.TextFrame.TextRange
                               For I = 0 To UBound(TargetList)
                               Set rngFound = txtRng.Replace(TargetList(I), DestinationList(I))
                               Do While Not rngFound Is Nothing
                               Set rngFound = txtRng.Replace(TargetList(I), DestinationList(I), After:=rngFound.Start + rngFound.Length, wholewords:=True)
                               Loop
                               Next
                           End If
                       End If

            End Select


End Sub

我收到此代码的运行时9错误。

同样,此代码仅替换某些单词(例如“ ie”和“ eg:”)的首次出现,但我想替换所有出现的单词。

#1楼 票数:0 已采纳

错误的原因是您尝试引用DestinationList数组中的第21个项目,并且该项目不存在,因为您缺少“ pm”的相应参数,为此我添加了错误检查,并更正了I,K的Dim行,X,并在循环数组时将0更改为LBound,因为如果基数不为0,也会引起问题。 更正的代码:

Option Explicit

Private ArrayError As Boolean

Sub FindAndReplace()
 Dim Pres As Presentation
 Dim sld As Slide
 Dim shp As Shape

 ArrayError = False
 For Each Pres In Application.Presentations
      For Each sld In Pres.Slides
         For Each shp In sld.Shapes
             If Not ArrayError Then checklist shp
         Next shp
     Next sld
 Next Pres
 If Not ArrayError Then MsgBox "Completed Succesfully!"
 End Sub

Sub checklist(shp As Object)

    Dim txtRng As TextRange
    Dim rngFound As TextRange
    Dim I As Long, K As Long, X As Long
    Dim iRows As Integer
    Dim iCols As Integer
    Dim TargetList, DestinationList

    TargetList = Array("        ", "       ", "      ", "     ", "    ", "   ", "  ", " / ", "i.e. ", "e.g. ", "/ ", " /", " :", " ;", " .", " ,", " - ", "resume", "a.m.", "p.m.", ":00")
    DestinationList = Array(" ", " ", " ", " ", " ", " ", " ", "/", "i.e., ", "e.g., ", "/", "/", ":", ";", ".", ",", " ? ", "résumé", "am", "pm", "")

    If Not UBound(TargetList) = UBound(DestinationList) Then
      MsgBox "Search and Replace arrary do not have the same number of arguments.", vbCritical + vbOKOnly, "Arrays Don't Match"
      ArrayError = True
      Exit Sub
    End If

       With shp

       If shp.HasTable Then
       For iRows = 1 To shp.Table.Rows.Count
                    For iCols = 1 To shp.Table.Rows(iRows).Cells.Count
                        Set txtRng = shp.Table.Rows(iRows).Cells(iCols).Shape.TextFrame.TextRange
                               For I = LBound(TargetList) To UBound(TargetList)
                               Set rngFound = txtRng.Replace(TargetList(I), DestinationList(I))
                               Do While Not rngFound Is Nothing
                               Set rngFound = txtRng.Replace(TargetList(I), DestinationList(I), After:=rngFound.Start + rngFound.Length, wholewords:=True)
                               Loop
                               Next
                        Next
                Next
       End If

     End With


           Select Case shp.Type


            Case msoGroup
                For X = 1 To shp.GroupItems.Count
                    Call checklist(shp.GroupItems(X))
                Next X

            Case 21
                For X = 1 To shp.Diagram.Nodes.Count
                    Call checklist(shp.GroupItems(X))
                Next X

            Case Else

                 If shp.HasTextFrame Then
                           If shp.TextFrame.HasText Then
                               Set txtRng = shp.TextFrame.TextRange
                               For I = LBound(TargetList) To UBound(TargetList)
                               Set rngFound = txtRng.Replace(TargetList(I), DestinationList(I))
                               Do While Not rngFound Is Nothing
                               Set rngFound = txtRng.Replace(TargetList(I), DestinationList(I), After:=rngFound.Start + rngFound.Length, wholewords:=True)
                               Loop
                               Next
                           End If
                       End If

            End Select


End Sub

  ask by Pandi Muthu translate from so

未解决问题?本站智能推荐:

1回复

PowerPointVBA宏:运行时错误9

我遇到了以下代码的运行时错误9:下标超出范围,但最初运行良好。 但是后来当我协作所有模块来创建加载项时,显示错误。
1回复

运行时错误'-2147188160(80048240)'VBAPowerpoint

我正在使用代码通过命令按钮或宏将演示文稿属性呈现给文本框或形状。 当我运行它时,我收到一个运行时错误,指出“ SlideShowWindows(unknown member):整数超出范围。1不在1到0的有效范围内 我该怎么办!? 提前致谢!
1回复

确定是否调用属性的一般方法会引发错误

假设您有一张带有一个图表的幻灯片,并且您运行此代码(在2007年之后的Office版本中): 您将生成错误: 应用程序定义或对象定义的错误 我相信这是因为“Office 2010中不推荐使用智能标记。”( 来源 ),一般来说,为了避免抛出错误和退出VBA这类问题,您可以采用以下两种
1回复

在PowerPoint中使用VBA宏将超链接添加到图片

我正在尝试使用VBA / Macros在单击时将超链接附加到图像的PowerPoint的“母版幻灯片”页面。 我已经添加了照片,现在正在寻找可以添加“ www.comment.com/connect”的功能 我应该使用.Hyperlink.Address = "www.comment.co
1回复

在PowerPoint中更改幻灯片时如何运行vba代码?

更换幻灯片时,我试图重置一些文本框和标签的内容,但我正努力使其工作。 经过大量的谷歌搜索和搜索后,我想出了这个方法,但是它似乎没有用。 我正在尝试在PowerPoint 2013和2016中使用OnSlideShowPageChange事件,但它似乎没有效果。 我不习惯使用PowerPoi
1回复

错误处理不适用于幻灯片ID

在处理我的代码中的异常时遇到麻烦。 我已经编写了下面的代码,将PowerPoint表的内容传输到数组中,但是它始终抛出异常, 幻灯片(未知成员):无效的请求。 无效的幻灯片ID。 我放入错误句柄以尝试并跳过此问题,因为如果在出现错误的情况下将该条目留空,这对我来说并不重要。 但是
1回复

VBA宏上的运行时错误

我正在使用VBA代码从Outlook电子邮件中获取文本并将其放置在我设置的Excel工作表中。 我正在使用Excel2010。我的电子邮件包含以下信息: 公司:ABC公司 上课时间:2013-10-29至2014-10-22 我已经设置了一个For With循环来浏览电子邮件,并在
1回复

PowerPointVBA宏给出运行时错误448:找不到命名参数

我正在尝试创建PowerPoint 2010 VBA宏以向每个幻灯片添加一个文本框。 但是,使用MSOffice文档中的命令创建文本框甚至不起作用。 这返回 文档是否错误或我缺少什么?