debugging VBA,第9次迭代调试时的范围查找错误?

ipakzgxi  于 2023-08-06  发布在  其他
关注(0)|答案(2)|浏览(78)

此程序从.xlsx文档运行,并更改关联的.docx文档,替换两个标记之间的选定文本。迭代1-8按预期工作,但在第9次迭代的中途,范围偏移50个字符,并在剩余迭代中保持偏移50个字符。特别是在第9次迭代时,startPos仍然正确,但stopPos偏移-50。然后,在第10次迭代中,startPos从stopPos停止的地方开始,向后返回-50个字符。
引用的excel工作表的格式为:

  • |关闭标签1|替换|替换|Replacement|
  • |关闭标签2|替换|替换|Replacement|
  • 等等

Public subWordFindAndReplaceTEST()

'<----------------------------- Declarations ----------------------------->
  Dim msWord As Object
  Dim doc As Word.Document
  Dim documentText As String
  Dim firstTerm As String, secondTerm As String
  Dim toReplaceTerm As String, replacementTerm As String

  Dim masterSheet As String 'Easy editing of xlsx worksheet name
  Dim cellIterator As Integer
  Dim cellStart As Integer 'Row number that Tags start on
  Dim tag1Col As String * 1, tag2Col As String * 1, _
      toReplaceCol As String * 1, replacementCol As String * 1 'Variables that point to xlsx rows
  Dim readFilePath As String, writeFilePath As String

  Dim startPos As Long 'Stores the starting position of firstTerm
  Dim stopPos As Long 'Stores the starting position of secondTerm based on first term's location
  Dim beginPosition As Long 'The next position to search for the firstTerm
  Dim myRange As Word.Range 'Total range of the section between firstTerm and secondTerm

  '<----- Easy Variable Updating ----->
  'FilePath to read from
  readFilePath = Application.ActiveWorkbook.Path & "\ReportDoc.docx"

  'User Input for FilePath to write to (Paths directly to folder xlsx sheet is in)
  writeFilePath = InputBox("What would you like to save this file as?" _
      & vbLf & vbLf & vbLf & Application.ActiveWorkbook.Path & "\", "Save As", "TestDocument.docx")
  If writeFilePath = "" Then Exit Sub 'Exits if user hits "Cancel"

  'Xlsx Variables
  masterSheet = "Replace Example"      'Name of the xlsx sheet to search for tags
  cellStart = 2                        'Row of the first instance of tags
  tag1Col = "A"                        'Column of the section begin tags
  tag2Col = "B"                        'Column of the section end tags
  toReplaceCol = "C"                   'Column of text that represents variable to replace
  replacementCol = "D"                 'Column of text to replace variable
  '<---------------------------------->

  '<--------------------------- Document Opening --------------------------->
  'Error catching required for opening document
  On Error Resume Next
  Set msWord = GetObject(, "Word.Application")
  If msWord Is Nothing Then
      Set msWord = CreateObject("Word.Application")
  End If
  On Error GoTo 0

  'Setting data values from designated xlsx cells
  cellIterator = cellStart
  With Worksheets(masterSheet)
      firstTerm = .Range(tag1Col & cellIterator).Value2
      secondTerm = .Range(tag2Col & cellIterator).Value2
      toReplaceTerm = .Range(toReplaceCol & cellIterator).Value2
      replacementTerm = .Range(replacementCol & cellIterator).Value2
  End With

  'Opening document
  With msWord
      .Visible = True
      Set doc = .Documents.Open(readFilePath)
      .Activate

      'Saving as new document
      doc.SaveAs2 Filename:=Application.ActiveWorkbook.Path & "\" & writeFilePath, _
          FileFormat:=wdFormatDocumentDefault

      '<----------------------------- Rangefinding ----------------------------->
      'Repeating process until cells are empty
      Do While firstTerm <> ""

          'Resetting Variables
          startPos = 0
          stopPos = 0

              'Get all the document text and store it in a variable.
              documentText = doc.Content
              Set myRange = doc.Range 'Initializing myRange object
              beginPosition = 1 'Setting beginning position

              'Error catch begin
              On Error Resume Next

                  '<--------- Getting range ---------->
                  startPos = InStr(beginPosition, documentText, firstTerm, vbTextCompare)

                  'Issue arises here on 9th iteration
                  stopPos = InStr(startPos, documentText, secondTerm, vbTextCompare)
                  '<---------------------------------->

              'Basic error catch for invalid input
              If Err.Number <> 0 Then
                  If Err.Number = 5 Then
                      'Immediately quits document without saving
                      'Prevents errors with rerunning the macro
                      .Quit SaveChanges:=False
                      MsgBox Err.Description & vbLf & "Make sure tags being searched for are in the document."
                      Exit Sub
                  Else
                      'Error catching for alternative issues
                      MsgBox Err.Description
                  End If
              End If

              'Reset Error
              On Error GoTo 0

              'Shows start/end tags compared to actual start/end position
              'MsgBox doc.Range(startPos, startPos + Len(firstTerm)) & " || " & firstTerm & _
                  vbLf & doc.Range(stopPos, stopPos + Len(secondTerm)) & " || " & secondTerm '~DL

              myRange.SetRange Start:=startPos, End:=stopPos

              With myRange.Find
                  .ClearFormatting
                  .Replacement.ClearFormatting
                  .Text = toReplaceTerm

                  'Handles strings too long for Find
                  If Len(replacementTerm) > 250 Then
                      'User Defined
                      stringOverflow replacementTerm, toReplaceTerm, myRange, doc
                  Else
                      .Replacement.Text = replacementTerm
                  End If

                  'Formatting options
                  .Replacement.Font.Italic = False
                  .Replacement.Highlight = False

                  .Forward = True
                  .Wrap = wdFindStop
                  .MatchCase = False
                  .MatchWholeWord = True
                  .MatchWildcards = False
                  .MatchSoundsLike = False
                  .MatchAllWordForms = False
                  .Execute Replace:=2 'wdReplaceAll
              End With

          'Iterates to next row in Excel
          cellIterator = cellIterator + 1
          With Worksheets("Replace Example")
              firstTerm = .Range(tag1Col & cellIterator).Value2
              secondTerm = .Range(tag2Col & cellIterator).Value2
              toReplaceTerm = .Range(toReplaceCol & cellIterator).Value2
              replacementTerm = .Range(replacementCol & cellIterator).Value2
          End With
      Loop

字符串
结束子
我已经尝试在循环之间重置所有变量,我相当有信心,尽管在第9次迭代之后偏移量是一致的,但偏移量在每个循环中都被重新创建,而不是结转。
我发现问题出现在第一个InStr()和第二个InStr()之间的“获取范围”部分。我已经检查过了,我相信这个问题不是因为使用的任何字符串超过了最大长度,也不是因为每个部分或整个文档的长度。
编辑:我尝试使用stopPos = InStr(beginPosition,documentText,secondTerm,vbTextCompare)来使stopPos独立于startPos,并且在相同的位置发生相同的问题。

8oomwypt

8oomwypt1#

无论您为startPos获取什么值,在该位置必须有与您的firstTerm匹配的值。也许该文档中有多个匹配项,并且您期望第二个匹配项,但InStr给您的是第一个匹配项?
尝试在第一个InStr下面添加以下行:

startPos = InStr(beginPosition, documentText, firstTerm, vbTextCompare)
debug.print Mid(documentText, (startPos - 20), (Len(firstTerm) + 40))

字符串
这将显示正在找到的匹配项,以及匹配项之前/之后的20个字符。

t40tm48m

t40tm48m2#

如果有人遇到这个问题,我设法使用Find函数返回文档中的确切范围,无论是否有隐藏或格式化字符:

Private Function findTagRange(tag As String, ByVal rng As Word.Range)
With rng.Find
    .Text = tag
    .MatchCase = False
    .Execute
    If .Found Then
        findTagRange = rng.Start
    Else
        findTagRange = -1
    End If
End With

字符串
结束函数

相关问题