Блог

Главная - Вопросы по программированию - Удаление вручную в Word VBA удаляет только первый элемент в массиве

Удаление вручную в Word VBA удаляет только первый элемент в массиве

#arrays #excel #vba #ms-word #comments

Вопрос:

У меня есть большой скрипт VBA, написанный в Word, который извлекает все комментарии из документа Word и записывает их в электронную таблицу Excel. Кроме того, он определяет (в соответствии с датой, выбором пользователя и статусом разрешения комментариев) комментарии, которые могут быть удалены. Я сохраняю индекс комментария в массиве, а затем обрабатываю массив, чтобы удалить каждый комментарий (отрывок приведен ниже, полный код в конце).:

     For DeleteCommentIndex = LBound(DeleteItems) To UBound(DeleteItems)

        StatusBar = "Deleting comment #" amp; DeleteCommentIndex   1 amp; " of " amp; UBound(DeleteItems)   1 _
            amp; ", comment index #" amp; DeleteItems(DeleteCommentIndex)
        MsgBox DeleteCommentIndex amp; "-" amp; DeleteItems(DeleteCommentIndex)
        ActiveDocument.Comments(DeleteItems(DeleteCommentIndex)).DeleteRecursively

    Next DeleteCommentIndex

В коде массив DeleteItems устанавливается как:

 Dim DeleteItems() as Integer

…а затем ПОВТОРИТЕ, когда я найду другой индекс комментариев для добавления в список.

Когда макрос завершается, я вижу, что в документе есть несколько вариантов отмены, которые соответствуют количеству комментариев, которые были удалены: скриншот списка отмен Word . Однако, когда я проверяю комментарии, на самом деле удаляется только первый комментарий. В моем окне сообщения (в соответствии с кодом) отображается правильная позиция массива и правильное значение в массиве. Кроме того, я могу отобразить окно сообщения, в котором будет показан правильный текст комментария. Когда я сразу же после этого повторно запускаю макрос, следующий элемент массива удаляется. Это похоже на то, что удаление автоматически срабатывает только один раз для первого элемента массива за цикл For — Next.

Где я ошибся? Заранее спасибо. (полный код ниже)

 Sub exportComments()
' Exports comments from a MS Word document to Excel and associates them with the text and page number
' Thanks to Graham Mayor, http://answers.microsoft.com/en-us/office/forum/office_2007-customize/export-word-review-comments-in-excel/54818c46-b7d2-416c-a4e3-3131ab68809c
' and Wade Tai, http://msdn.microsoft.com/en-us/library/aa140225(v=office.10).aspx
' Need to set a VBA reference to "Microsoft Excel 14.0 Object Library"


Dim xlApp As Object
Dim xlWB As Excel.Workbook
Dim i, HeadingRow, WriteRow, WriteCommentRow, WriteDeletedRow, CelltoFormat, ReviewerCellToFormat As Integer
Dim ReviewWriteRow, SheetToFormat, IndexValue, CountDeleteItems As Integer
Dim CellColour, FontColour As Integer, IsBold As Boolean
Dim RowIsAged As Boolean
Dim objPara As Paragraph
Dim objComment As Comment
Dim strSection, WriteToSheet As String
Dim strTemp
Dim myRange As Range
Dim lngIndex As Long
Dim lastRow, DoYouWantToDelete As Integer
Dim DeleteDate As String
Dim CommentRow(9) As Variant 'Create an array to hold the comment information
Dim DeleteItems() As Integer

'These three values affect the formatting of the header row
CellColour = 11
FontColour = 2
IsBold = True

CelltoFormat = 1
ReviewerCellToFormat = 1
RowIsAged = False
IndexValue = 1
CountDeleteItems = -1

If ActiveDocument.Comments.Count = 0 Then
    MsgBox "The document contains no comments"
    Exit Sub
End If

' First check to see if the user wants to delete old comments
' Firstly, get the date from which comments should be deleted

DoYouWantToDelete = MsgBox("Do you wish to delete aged comments from this document?", _
                    vbQuestion   vbYesNo   vbDefaultButton2, "Delete aged comments?")

If DoYouWantToDelete = vbYes Then
    DeleteDate = InputBox("Please enter a date (comments older than this date will be removed)" amp; _
                    vbCrLf amp; vbCrLf amp; "Use the format dd/mm/yy", "Deleting old comments", "Please enter a date in format dd/mm/YYYY")
    
    If IsDate(DeleteDate) Then
        DeleteDate = CDate(DeleteDate)
    Else
        MsgBox "Wrong date format" amp; vbCrLf amp; vbCrLf amp; "Please rerun the macro with a correct date format"
        Exit Sub
    End If
    
Else
    MsgBox "No comments will be deleted"
End If

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add 'create a new workbook
xlWB.Sheets.Add After:=xlWB.Worksheets(1)
xlApp.Sheets(1).Name = "Comments"
xlApp.Sheets(2).Name = "Reviewers"

If DoYouWantToDelete = vbYes Then 'If the user wants to delete comments, create a sheet to capture the info
    xlWB.Sheets.Add After:=xlWB.Worksheets(2)
    xlApp.Sheets(3).Name = "DeletedComments"
End If

xlApp.Worksheets("Comments").Activate

With xlWB.Worksheets(1)
' Create Heading
    HeadingRow = 1
    .Cells(HeadingRow, 1).Formula = "Comment"
    .Cells(HeadingRow, 2).Formula = "Page"
    .Cells(HeadingRow, 3).Formula = "Section"
    .Cells(HeadingRow, 4).Formula = "Text"
    .Cells(HeadingRow, 5).Formula = "Original Comment"
    .Cells(HeadingRow, 6).Formula = "Raised by"
    .Cells(HeadingRow, 7).Formula = "Date Raised"
    .Cells(HeadingRow, 8).Formula = "Replies"
    .Cells(HeadingRow, 9).Formula = "Last Update"
    .Cells(HeadingRow, 10).Formula = "Status"
    
    xlWB.Worksheets(2).Cells(1, 1).Value = "Initial"
    xlWB.Worksheets(2).Cells(1, 2).Value = "Name"
    
    For CelltoFormat = 1 To 10 '10 columns, format each one the same
        .Cells(HeadingRow, CelltoFormat).Interior.ColorIndex = CellColour
        .Cells(HeadingRow, CelltoFormat).Font.ColorIndex = FontColour
        .Cells(HeadingRow, CelltoFormat).Font.Bold = IsBold
    Next CelltoFormat
    
'Copy this format to the Deleted Comments tab (if we have one)
    If DoYouWantToDelete = vbYes Then
        xlWB.Worksheets("Comments").UsedRange.Copy
        xlWB.Worksheets("DeletedComments").Select
        xlWB.Worksheets("DeletedComments").Range("A1").Select
        xlWB.Worksheets("DeletedComments").Paste
    End If
  
    WriteCommentRow = 1
    WriteDeletedRow = 1
    ReviewerWriteRow = 2
    
    For i = 1 To ActiveDocument.Comments.Count 'For every comment in the document
        xlApp.StatusBar = "Processing comment " amp; i amp; " of " amp; ActiveDocument.Comments.Count
            
        Set myRange = ActiveDocument.Comments(i).Scope
        
        CommentRow(0) = IndexValue 'Write an index number
        CommentRow(1) = ActiveDocument.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber) 'Write the page number
        CommentRow(2) = ActiveDocument.Comments(i).Scope.Paragraphs(1).Range.ListFormat.ListString 'Write the section number
        CommentRow(3) = ActiveDocument.Comments(i).Scope.FormattedText 'Write the commented text
        CommentRow(4) = ActiveDocument.Comments(i).Range 'Write the comment itself
        CommentRow(5) = ActiveDocument.Comments(i).Initial 'Write the initials of who raised the comment
                      
        With xlWB.Worksheets(2) 'Write the reviewer and their initials to the Reviewer sheet
            .Cells(ReviewerWriteRow, 1).Value = ActiveDocument.Comments(i).Initial
            .Cells(ReviewerWriteRow, 2).Value = ActiveDocument.Comments(i).Author
        End With
        
        ReviewerWriteRow = ReviewerWriteRow   1
        
        CommentRow(6) = Format(ActiveDocument.Comments(i).Date, "MM/dd/yyyy") 'Write teh date the comment was raised
        
        If ActiveDocument.Comments(i).Replies.Count > 0 Then 'Go though all the replies add put them in the next field
           For lngIndex = 1 To ActiveDocument.Comments(i).Replies.Count
              
              
              CommentRow(7) = CommentRow(7) amp; ActiveDocument.Comments(i).Replies(lngIndex).Range.Text _
              amp; " [" amp; ActiveDocument.Comments(i).Replies(lngIndex).Initial amp; "] " _
              amp; " [" amp; Format(ActiveDocument.Comments(i).Replies(lngIndex).Date, "MM/dd/yyyy") amp; "] " _
              amp; vbNewLine amp; vbNewLine 'Add initials of who made the replay, and the date is was made
                           
              'CommentRow(8) = Format(ActiveDocument.Comments(i).Replies(lngIndex).Date, "mmddyyyy")
              CommentRow(8) = CDate(ActiveDocument.Comments(i).Replies(lngIndex).Date)
                            
              If DoYouWantToDelete = vbYes Then
                If CDate(CommentRow(8)) <= CDate(DeleteDate) Then
                      RowIsAged = True
                Else
                      RowIsAged = False
                End If
              End If
                
              With xlWB.Worksheets(2)
                .Cells(ReviewerWriteRow, 1).Value = ActiveDocument.Comments(i).Replies(lngIndex).Initial
                .Cells(ReviewerWriteRow, 2).Value = ActiveDocument.Comments(i).Replies(lngIndex).Author
              End With
              ReviewerWriteRow = ReviewerWriteRow   1
                         
           Next lngIndex
        Else 'There are no replies, so we need to set the last updated field to be the same date the comment was raised
            CommentRow(8) = Format(ActiveDocument.Comments(i).Date, "MM/dd/yyyy")
        End If
        
        If ActiveDocument.Comments(i).Done Then 'Get the comment status (open or resolved)
            CommentRow(9) = "Resolved"
        Else
            CommentRow(9) = "Open"
        End If
        
        'Now write the comment info to either the main comments tab, or the deleted comments tab
        If CommentRow(9) = "Resolved" And RowIsAged And DoYouWantToDelete = vbYes Then
            CountDeleteItems = CountDeleteItems   1
            ReDim Preserve DeleteItems(CountDeleteItems) 'Resize our tracking array
            WriteToSheet = "DeletedComments"
            WriteDeletedRow = WriteDeletedRow   1 'This is to track which row in our deleted comments sheet is next
            WriteRow = WriteDeletedRow
            DeleteItems(CountDeleteItems) = i 'Keep a note of which comments are to be deleted

        Else
            WriteToSheet = "Comments"
            WriteCommentRow = WriteCommentRow   1 'This is to track which row in our standard comments sheet is next
            WriteRow = WriteCommentRow
        End If
        
        If ActiveDocument.Comments(i).Replies.Count <> 0 Then
          i = i   ActiveDocument.Comments(i).Replies.Count 'Jump the counter forward to account for the replies
        End If
        
        For ArrayIndex = 0 To 9 'Now write each element of the array to the relevant row in the right tab
           xlWB.Worksheets(WriteToSheet).Cells(WriteRow, ArrayIndex   1).Value = CommentRow(ArrayIndex)
        Next ArrayIndex
        
        IndexValue = IndexValue   1
        
        Erase CommentRow() 'Clear the array ready for the next set of comments
        
    Next i
    
    xlApp.StatusBar = "Completed processing of " amp; ActiveDocument.Comments.Count amp; " comments"
    
    'Format the worksheets
    If DoYouWantToDelete = vbYes Then
        For SheetToFormat = 1 To 3 Step 2
          With xlWB.Worksheets(SheetToFormat)
            .Columns("A:J").Cells.HorizontalAlignment = xlHAlignLeft
            .Columns("A:J").Cells.VerticalAlignment = xlVAlignTop
            .Columns("A:J").Cells.WrapText = True
            .Columns("D:E").ColumnWidth = 50
            .Columns("G").ColumnWidth = 12
            .Columns("H").ColumnWidth = 50
            .Columns("I").ColumnWidth = 12
            .Columns("I").NumberFormat = "dd/mm/yyyy"
            .UsedRange.EntireRow.AutoFit
            'Add an autofilter to all the columns and freeze the top row
            .Columns("A:J").Autofilter
            xlApp.Cells(2, 1).Select
            xlApp.ActiveWindow.FreezePanes = True
          End With
        Next SheetToFormat
    Else
        With xlWB.Worksheets(1)
            .Columns("A:J").Cells.HorizontalAlignment = xlHAlignLeft
            .Columns("A:J").Cells.VerticalAlignment = xlVAlignTop
            .Columns("A:J").Cells.WrapText = True
            .Columns("D:E").ColumnWidth = 50
            .Columns("G").ColumnWidth = 12
            .Columns("H").ColumnWidth = 50
            .Columns("I").ColumnWidth = 12
            .Columns("I").NumberFormat = "dd/mm/yyyy"
            .UsedRange.EntireRow.AutoFit
            'Add an autofilter to all the columns and freeze the top row
            .Columns("A:J").Autofilter
            xlApp.Cells(2, 1).Select
            xlApp.ActiveWindow.FreezePanes = True
          End With
    End If

    'Remove duplicates in the Reviewers worksheet and format it
    With xlWB.Worksheets(2)
    
        .Columns("B").ColumnWidth = 30
    
        For ReviewerCellToFormat = 1 To 2
            .Cells(HeadingRow, ReviewerCellToFormat).Interior.ColorIndex = CellColour
            .Cells(HeadingRow, ReviewerCellToFormat).Font.ColorIndex = FontColour
            .Cells(HeadingRow, ReviewerCellToFormat).Font.Bold = IsBold
        Next ReviewerCellToFormat
            
        'Remove duplicates
        lastRow = .UsedRange.Rows.Count
        .Range("A1:B" amp; lastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
        
        'Sort the Reviewer names in alphabetical order
        lastRow = .UsedRange.Rows.Count 'We need to recheck this as the duplicates will have been removed
        .Range("A2:B" amp; lastRow).Sort key1:=.Range("A2:A" amp; lastRow), order1:=xlAscending, Header:=xlNo
    End With

End With

'Delete the comments before tidying up, setting focus and final status message
xlWB.Worksheets("Comments").Activate
Word.Application.Activate
 
If DoYouWantToDelete = vbYes Then
    'Go ahead and delete the comments
    
    MsgBox "There are " amp; UBound(DeleteItems)   1 amp; " comments to delete." amp; _
        vbCrLf amp; vbCrLf amp; "Are you sure you wish delete these?"
        
    For DeleteCommentIndex = LBound(DeleteItems) To UBound(DeleteItems)
    
        StatusBar = "Deleting comment #" amp; DeleteCommentIndex   1 amp; " of " amp; UBound(DeleteItems)   1 _
            amp; ", comment index #" amp; DeleteItems(DeleteCommentIndex)
        MsgBox DeleteCommentIndex amp; "-" amp; DeleteItems(DeleteCommentIndex)
        ActiveDocument.Comments(DeleteItems(DeleteCommentIndex)).DeleteRecursively
        
    Next DeleteCommentIndex

End If

MsgBox ("Comment processing is complete. In total, " amp; ActiveDocument.Comments.Count amp; " comments were processed." amp; vbCrLf amp; _
    vbCrLf amp; "We recommend you save the spreadsheet with a data and time stamp in the title.")

Set xlWB = Nothing
Set xlApp = Nothing
End Sub

Комментарии:

1. Попробуйте запустить цикл в обратном направлении, когда вы удаляете элемент из коллекции.

2. Другими словами, от Ubound(удаленные элементы) до LBound(удаленные элементы)?

3. For DeleteCommentIndex = Ubound(DeleteItems) to LBound(DeleteItems) Step -1 @StuartL

4. Большое Вам спасибо, похоже, это сделало свое дело! Любое объяснение того, почему он работает в обратном направлении по массиву, но не вперед?

5. Это распространенная ошибка, которую совершают люди, удаляющие элемент из коллекции в цикле. Когда вы удаляете элемент (скажем, 2-й элемент) из коллекции, остальные элементы, находящиеся за ним, увеличивают свой индекс на 1, но ваш цикл повторяется на основе исходного индекса. Удаляя с обратной стороны, вы не испортите индекс. Я не буду публиковать ответ на этот вопрос, так как это можно считать дублирующим вопросом (по этому вопросу задано много вопросов) @StuartL

Метки: