unable to copy content content from word and paste it into excel into a particular cells in sequence

[Kulasekaran]

Hi all,
I wrote a macro to enable track changes in word document and copy all the track changes content from word to excel. right now i am able to only copy the latest track changed content and not the all track changes(insert/ delete) into excel in particular cell for eg. in H30 the first track changes in inserted,
the second one must happen in H31 cell this is not happening. i am able to insert only in one row and this sequence insertions is not happening.

can somebody give suggestions...


Thanks in advance..
iam pasting my macro below



Public Sub TrackedChangesToNewDoc()


Dim oDoc As Document
Dim oExcel As Excel.Application
Dim oWB As Workbook
Dim tSheet As Worksheet
Dim oRange As Range
Dim oRevision As Revision
Dim strText As String
Dim n As Long
Dim i As Long
Dim Title As String
Dim S As String
Dim C As Integer
Dim rngRow As Range
Dim K As Integer
Dim fd As FileDialog
Dim FileName As String

Set fd = Application.FileDialog(msoFileDialogFilePicker)


Dim FileChosen As Integer

FileChosen = fd.Show
fd.Title = "Choose workbook"
fd.Filters.Clear
fd.Filters.Add "Excel workbook (.xls)", "*.xls"
fd.Filters.Add "Excel workbooks(.xlsx)", "*.xlsx"
fd.FilterIndex = 1
fd.ButtonName = "Choose this file"

If FileChosen <> -1 Then
GoTo ExitHere
Else
Set oExcel = New Excel.Application
FileName = fd.SelectedItems(1)
Set oWB = oExcel.Workbooks.Open(FileName)
Set tSheet = oWB.Sheets(4)
End If

Title = "Tracked Changes to New Document"
n = 0

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "active document contains no tracked changes.", vbOKOnly, Title
GoTo ExitHere
Else

GoTo ExitHere
End If
End If

'Application.ScreenUpdating = False

For Each oRevision In oDoc.Revisions
Select Case oRevision.Type


Case wdRevisionInsert, wdRevisionDelete

With oRevision

strText = .Range.Text
Set oRange = .Range
Do While InStr(1, oRange.Text, Chr(2)) > 0

i = InStr(1, strText, Chr(2))

If oRange.Footnotes.Count = 1 Then
strText = Replace(Expression:=strText, _
Find:=Chr(2), Replace:="[footnote reference]", _
Start:=1, Count:=1)

oRange.Start = oRange.Start + i


ElseIf oRange.Endnotes.Count = 1 Then
strText = Replace(Expression:=strText, _
Find:=Chr(2), Replace:="[endnote reference]", _
Start:=1, Count:=1)


oRange.Start = oRange.Start + i
End If
Loop

n = n + 1

With tSheet
If oRevision.Type = wdRevisionInsert Then
.Range("H30") = "Inserted" 'INSERTED
Else
.Range("H30") = "Deleted" 'DELETED
End If
.Range("F30") = oRevision.Range.Information(wdActiveEndAdjustedPageNumber) ' PAGE NUMBER
.Range("G30") = oRevision.Range.Information(wdFirstCharacterLineNumber) ' FIRST CHARACTER LINE NUMBER
.Range("E30") = strText ' ACTUAL TEXT
.Range("E12") = oRevision.Author ' AUTHORS NAME
.Range("J13") = Format(oRevision.Date, "mm-dd-yyyy") ' REVISION DATE

End With
End With
End Select
Next oRevision



MsgBox n & " tracked changed have been extracted from the Document " & _
" and Transforming the Changes to WorkBook.", vbOKOnly, Title

oExcel.Visible = True

ExitHere:

Set oExcel = Nothing

End Sub

 

[Damon Ostrander]

Hi Kulasekaran,

If I understand your problem correctly I believe you want something like this:

.
.
.
With tSheet
If oRevision.Type = wdRevisionInsert Then
.Range("H29").Offset(n,0) = "Inserted" 'INSERTED
Else
.Range("H29").Offset(n,0) = "Deleted" 'DELETED
End If
.Range("F29").Offset(n,0) = oRevision.Range.Information(wdActiveEndAdjustedPageNumber) ' PAGE NUMBER
.Range("G29").Offset(n,0) = oRevision.Range.Information(wdFirstCharacterLineNumber) ' FIRST CHARACTER LINE NUMBER
.Range("E29").Offset(n,0) = strText ' ACTUAL TEXT
.Range("E11").Offset(n,0) = oRevision.Author ' AUTHORS NAME
.Range("J12").Offset(n,0) = Format(oRevision.Date, "mm-dd-yyyy") ' REVISION DATE

End With
.
.
.