VBA for Word 2010 - How to copy text between a two headings in Word

Hi All

My apologies if the the title doesn't really match what I'm about to ask help for but I'm not sure how to succintly explain the following scenario:

I need to use VBA (I have some knowledge with Excel) to, whilst in an active word document, find two headings and select then copy the text that is between them e.g.

First Heading: "Summary"
Text: "Could be any length and with all sorts of fonts, sizes etc" >>> This is what I need to copy
Second Heading: "Conclusion"

The "Headings" are constant in each Word document but also exist in the Table of Contents so Pages 1 & 2 need to be bypassed. Once copied, the text (preferably including format etc) would be pasted into an Excel cell. I have 1700+ word docs to work with and the text between each heading can always change so this is something I would greatly appreciate any form of help wih. I've been trawling the web for 3 days now and yet to discover code that works.

Can you please help a fellow who is always willing to help others out where he can?

Thank you for your consideration

Are the documents all in the same folder?
Are the headings always the same (i.e "Summary" and "Conclusion")?
Do the headings use Word's Heading Styles - consistently?
Does the Excel workbook already exist, or is the macro to create one?
Is the code to be run from Word, or Excel?

Copying & pasting Word content that may span section breaks, manual page breaks and tables, then pasting the lot into a single Excel cell can cause problems. Amongst other things, you can't paste a Word table into an Excel cell.

For some Excel code that might get you started, see: http://www.vbaexpress.com/forum/show...ent-into-excel

Dear Paul,

Thank you for your reply and MY SINCEREST APOLOGIES for not thanking you sooner - my job sends me from pillar to post and I got very sidetracked from this task... I'm going to look at your suggestion further, which I believe will be a great starting point. With regards your questions though (and if you're still happy to help me...):

1/ Documents are all in different folders in the same network drive
2/ Headings are always the same and always constant
3/ Headings are always using Word's default Heading 1 Style
4/ Excel workbook already exists
5/ Upon opening the Excel workbook the code runs

The code would ideally perform the following way:

1/ Workbook is opened by user and code runs automatically
2/ Code looks at cell A1 in Sheet1, if A1 = TRUE then look at B1 (which is the cell that contains the file location e.g. S:\Clients\Client Name\Client Study\Filename.docx)
3/ Open File location
4/ Go to Heading Style 1 which is called "Summary"
5/ From next line below "Summary" copy all text until the next Heading Style 1 Named "Conclusion" - don't copy "Conclusion" and being able to copy formatting is a wish not a want
6/ Take copied text (no tables-just text but this can span over two pages but never more than this and should keep within Excel 2010 cell character limit ok)
7/ Go to adjacent cell to the Filename location in sheet1 - in this case C1
8/ Paste values (+ formatting if possible) into cell C1
9/ Go to next TRUE in column A and repeat above until last TRUE

*If possible a sort of where filename location is incorrect/doesn't exist then have the adjacent cell equal "Please check File Location" would be a super help

If you can think of any more questions I will respond asap. Many thanks for the help so far!

Kind regards,

Paul

You could use a macro like the following:

Code:

---

Sub UpdateData()
Application.ScreenUpdating = False
Dim wdApp As Object, wdDoc As Object, wdRng As Object
Dim WkSht As Worksheet, LRow As Long, i As Long
Set WkSht = ThisWorkbook.Sheets("Sheet1")
LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wdApp = CreateObject("Word.Application")
If wdApp Is Nothing Then
  MsgBox "Can't start Word.", vbExclamation
  Exit Sub
End If
With WkSht
  For i = 1 To LRow
    If LCase(.Cells(i, 1).Text) = "true" Then
      If Dir(.Cells(i, 2).Text, vbNormal) = "" Then
        .Cells(i, 3).Value = "Please check File Location"
      Else
        Set wdDoc = wdApp.Documents.Open(Filename:=.Cells(i, 2).Text, _
          AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
        With wdDoc
          With .Range
            With .Find
              .ClearFormatting
              .Replacement.ClearFormatting
              .Forward = True
              .Wrap = 0 'wdFindStop
              .Format = True
              .Style = "Heading 1"
              .MatchWildcards = False
              .MatchCase = False
              .Text = "Summary^p"
              .Replacement.Text = ""
              .Execute
            End With
            If .Find.Found Then
              Set wdRng = .Duplicate
              wdRng.Collapse 0 'wdCollapseEnd
            End If
            .Start = wdRng.End
            With .Find
              .Text = "Conclusion"
              .Execute
            End With
            If .Find.Found Then
              wdRng.End = .Duplicate.Start - 1
            End If
            If Not wdRng Is Nothing Then
              With wdRng
                While .Tables.Count > 0
                  .Tables(1).Delete
                Wend
                With .Find
                  .ClearFormatting
                  .Replacement.ClearFormatting
                  .Forward = True
                  .Wrap = 0 'wdFindStop
                  .Format = False
                  .MatchWildcards = True
                  .Text = "[^13^l]{1,}"
                  .Replacement.Text = Chr(182)
                  .Execute Replace:=2 'wdReplaceAll
                End With
                If Len(.Text) > 1 Then
                  .Copy
                  With WkSht
                    .Paste .Cells(i, 3)
                  End With
                Else
                  WkSht.Cells(i, 3).Value = "No Data"
                End If
              End With
            Else
              WkSht.Cells(i, 3).Value = "Not Found"
            End If
          End With
          .Close SaveChanges:=False
        End With
        Set wdRng = Nothing
      End If
    End If
  Next
  '.Columns(3).Cells.Replace What:="¶", Replacement:=Chr(10), _
    LookAt:=xlPart, SearchOrder:=xlByRows
  .Columns(3).WrapText = True
End With
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

---

As coded, except for paragraph breaks and any list-numbering & bullets, the formatting is preserved. The paragraph breaks are replaced by ¶ symbols. The macro also includes comment-out code for replacing those with line breaks, but that kills the character formatting. The only viable alternative would seem to be to store every font attribute change in the string (eg, font name, point size, italics, bold, underline), of which there could be many, replace the ¶ symbols, then re-apply all those formats - a lot of extra work. I'll leave it to you to either:
1. manually replace the ¶ symbols with line breaks;
2. program the format-restoration code; or
3. implement just the line breaks and forego the formatting.

Dear Paul,

Thank you SO much for replying - to be totally honest I was checking my emails for an update from vbaexpress but never got one so I just assumed I had left it too late in thanking you for your original reply. It turns out you did reply and I didn't even know!! I ended up trying my own coding on this but I'm just not competent enough yet.
I have quickly tested the code and it works!!! :crying: I have to try a few tweaks out but when I realised you had replied with the code I just want to buy you the biggest pint of Fosters ever!!! You're the best man! I'll be in touch with my (and no doubt there will be) questions if that's ok?

Thanks again Paul - cheers from Ireland

Quote:

---

Originally Posted by pk247

I was checking my emails for an update from vbaexpress but never got one
...
I'll be in touch with my (and no doubt there will be) questions if that's ok?

---

I suggest you check your VBAX profile and ensure your 'Messaging & Notification' settings and email address are correct.

By all means, if you have more questions, do a follow-up post.

Quote:

---

Originally Posted by macropod

I suggest you check your VBAX profile and ensure your 'Messaging & Notification' settings and email address are correct.

By all means, if you have more questions, do a follow-up post.

---

Dear Paul,

Thanks for the advice - I checked my account and received your email notification this morning so maybe the previous response went to SPAM. Can I just say a massive thanks again for the code - it works really well and I tested it on my range of 1700+ documents in work this morning and I almost got 100% success but for a few code "tweaks" that I hope you can help me with please:

1/ Is it possible to prevent images (by this I mean screenshots, .msg outlook pastes etc) from being copied into the cell adjacent to the filename? Just the text is required and although the images paste into the Excel file ok I really don't require them and this would save me having to delete them all manually.
2/ Is it possible to change the code in such a way that it looks at the "Folder Location" in column B (e.g. S:\Clients\Client Name\Client Study\... ) and then selects the "last modified" .doc or .docx file (I assume .doc*) and then performs the extraction of text code? I'm pretty sure this is a big ask but it would save so much time and effort if it was possible to do.

By any account you have definitely went above and beyond for me with the code you have written so far. I should have anticipated the above 2 tweaks but as always hindsight is a wonderful thing... Hope you can help me out again Paul

**One more thing, dare I ask how you learned how to do all this? I reckon you could wipe out so many of the manual processes in my workplace - truly a cool skill to have!

Kind regards,

Paul, Ireland

Quote:

---

Originally Posted by pk247

1/ Is it possible to prevent images (by this I mean screenshots, .msg outlook pastes etc) from being copied into the cell adjacent to the filename? Just the text is required and although the images paste into the Excel file ok I really don't require them and this would save me having to delete them all manually.

---

To exclude any graphics, you could insert:

Code:

---

                                    While .Shapes.Count > 0
                                        .Shapes(1).Delete
                                    Wend
                                    While .InlineShapes.Count > 0
                                        .InlineShapes(1).Delete
                                    Wend

---

after:

Code:

---

                                    While .Tables.Count > 0
                                        .Tables(1).Delete
                                    Wend

---

Quote:

---

2/ Is it possible to change the code in such a way that it looks at the "Folder Location" in column B (e.g. S:\Clients\Client Name\Client Study\... ) and then selects the "last modified" .doc or .docx file (I assume .doc*) and then performs the extraction of text code? I'm pretty sure this is a big ask but it would save so much time and effort if it was possible to do.

---

That would require a substantial re-write of the code. As written, the macro looks for the file named in column B. If you give it just a folder, the code would then have to check every document in that folder to determine which one is the most recent and only then continue with processing.

Quote:

---

**One more thing, dare I ask how you learned how to do all this?

---

Basically, it's all self-taught. Most of what I've learnt has come about from helping people in different forums resolve their problems. None of it has any connection with my former employment (I'm retired) where, ironically, I was regarded as an Excel specialist.

Hi Paul,

Thanks for the help again! It's coincidental - people in my work think I'm an Excel specialist but the more I work with Excel the more I realize I'm only scraping the surface and need to practice more with it and Word! There's a lot to be said for teaching yourself how to do something and by you helping others out at the same time (including me) I hope Karma is treating you well...

Thank you for the exclude graphics code - it works a treat!

As for the "latest .doc / .docx file in folder" I went trawling for something similar on the web and found some useful code (I tried pasting the URL but it was "denied"?)

I adapted the code to this (took me an hour or so and apologies if there is unnecessary code...) and sorry for not having the VB box (I don't know how to do this yet):



VB:
[Code]
Sub GetMostRecentFile()

Dim FileSys As FileSystemObject
Dim objFile As file
Dim myFolder
Dim strFilename As String
Dim dteFile As Date
Dim wdApp As Object, wdDoc As Object, wdRng As Object

Set wdApp = CreateObject("Word.Application")

'set path for files - change for your folder
Const myDir As String = "C:\Users\Test Folder\"

'set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)

'loop through each file and get date last modified. If largest date then store Filename
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Name
End If
Next objFile

wdApp.Documents.Open myDir & strFilename

wdApp.Visible = True

Set FileSys = Nothing
Set myFolder = Nothing
End Sub



--The above vb code does indeed look in the folder, find the latest Word document and opens it.

So Paul, rather than ask you to please write the code for me, could I ask you this instead? In your opinion do you think it is possible to adapt the above code into theSub UpdateData() that you wrote? And if so what would be the least obvious thing for me to notice whilst I start working on incorporating the code?

I really appreciate you taking the time (and patience..) to help me.

Kindest regards,

Paul, Ireland

Sorry Paul - there's a snag. The code in "Sub GetMostRecentFile()" goes to open the latest file no matter the file type (eg excel, .txt, anything...) there shouldn't really be any other file types in the folders I'm working with but Word although I'm going to have to "trawl the web" for more ideas on this just to prevent the old debug messages... I'm sure you would have noticed this in the code anyway but just in case anyone else reading this post doesn't see it I thought I'd quickly post this.

Thanks, Paul

Try:

Code:

---

Sub UpdateData()
    Application.ScreenUpdating = False
    Dim wdApp As Object, wdDoc As Object, wdRng As Object
    Dim WkSht As Worksheet, LRow As Long, i As Long
    Dim strFldr As String, strFile As String, StrDoc As String
    Dim FSObj As Object, FSOFile As Object, DtTm As Date
    Set WkSht = ThisWorkbook.Sheets("Sheet1")
    LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
    Set wdApp = CreateObject("Word.Application")
    If wdApp Is Nothing Then
        MsgBox "Can't start Word.", vbExclamation
        Exit Sub
    End If
    With WkSht
        For i = 1 To LRow
            If LCase(.Cells(i, 1).Text) = "true" Then
                strFldr = .Cells(i, 2).Text
                If Dir(strFldr, vbDirectory) = "" Then
                    .Cells(i, 3).Value = "Please check Folder Location"
                Else
                    If FSObj Is Nothing Then Set FSObj = CreateObject("Scripting.FileSystemObject")
                    'loop through each file and get date last modified. If largest date then store Filename
                    DtTm = DateSerial(1900, 1, 1)
                    strFile = Dir(strFldr & "\*.doc", vbNormal)
                    While strFile <> ""
                        Set FSOFile = FSObj.GetFile(strFldr & "\" & strFile)
                        If FSOFile.DateLastModified > DtTm Then
                            DtTm = FSOFile.DateLastModified
                            StrDoc = strFldr & "\" & strFile
                        End If
                        strFile = Dir()
                    Wend
                    Set FSOFile = Nothing
                    Set wdDoc = wdApp.Documents.Open(Filename:=StrDoc, _
                        AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
                    With wdDoc
                        With .Range
                            With .Find
                                .ClearFormatting
                                .Replacement.ClearFormatting
                                .Forward = True
                                .Wrap = 0 'wdFindStop
                                .Format = True
                                .Style = "Heading 1"
                                .MatchWildcards = False
                                .MatchCase = False
                                .Text = "Summary^p"
                                .Replacement.Text = ""
                                .Execute
                            End With
                            If .Find.Found = True Then
                                Set wdRng = .Duplicate
                                wdRng.Collapse 0 'wdCollapseEnd
                            End If
                            .Start = wdRng.End
                            With .Find
                                .Text = "Conclusion"
                                .Execute
                            End With
                            If .Find.Found = True Then
                                wdRng.End = .Duplicate.Start - 1
                            End If
                            If Not wdRng Is Nothing Then
                                With wdRng
                                    While .Tables.Count > 0
                                        .Tables(1).Delete
                                    Wend
                                    While .Shapes.Count > 0
                                        .Shapes(1).Delete
                                    Wend
                                    While .InlineShapes.Count > 0
                                        .InlineShapes(1).Delete
                                    Wend
                                    With .Find
                                        .ClearFormatting
                                        .Replacement.ClearFormatting
                                        .Forward = True
                                        .Wrap = 0 'wdFindStop
                                        .Format = False
                                        .MatchWildcards = True
                                        .Text = "[^13^l]{1,}"
                                        .Replacement.Text = Chr(182)
                                        .Execute Replace:=2 'wdReplaceAll
                                    End With
                                    If Len(.Text) > 1 Then
                                        .Copy
                                        With WkSht
                                            .Paste .Cells(i, 3)
                                        End With
                                    Else
                                        WkSht.Cells(i, 3).Value = "No Data"
                                    End If
                                End With
                            Else
                                WkSht.Cells(i, 3).Value = "Not Found"
                            End If
                        End With
                        .Close SaveChanges:=False
                    End With
                    Set wdRng = Nothing
                End If
            End If
        Next
        '.Columns(3).Cells.Replace What:="¶", Replacement:=Chr(10), _
        LookAt:=xlPart, SearchOrder:=xlByRows
        .Columns(3).WrapText = True
    End With
    wdApp.Quit
    Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
    Application.ScreenUpdating = True
End Sub

---

PS: The code tags are inserted via the # button on the posting menu.

Thank you so much Paul!! I'm just up and awake (and it feels like Christmas :)) I quickly tested the code on my home computer and it works perfectly - I'll try it out in work later and let you know how the real test gets on - I'm sure it'll be grand though. Cheers!

Kind regards,

Paul, Ireland

Hi Paul,

My apologies for the eternal list of requests/questions on this but for some reason I'm experiencing issue with:

Code:

---

While .Shapes.Count > 0

---

It's coming up with Run-time error '438' Object doesn't support this method. I have tried figuring it out for myself and even found posts from you in 2012 but to no avail for the code above (nobody seems to want to delete their shapes). Could it be I haven't referenced (Tools\References) an Object from the Library? Please help with this one if you can - I have tested the code by inserting photos into Word docs and they don't pull through yet actual shapes (Circles, Rectangles etc) prompt the debug message but by removing the following code the shape is copied into the adjacent cell to the folder location (no debug):

Code:

---

While .Shapes.Count > 0
          .Shapes(1).Delete
Wend

---

May I also ask if you know much about error handling in Word at all and how it might be used with the code? You see, I can live with a few files being skipped if there is some sort of error (with perhaps text in the adjacent cell "Please check document layout") because it would would be really useful just to prove to my colleagues that the code loops through all the files in folders in one go without having me stop at the odd file to debug the Word document.

If you can help in any way it would be much appreciated. I'm pretty sure these last two requests will resolve everything I need to do.

Thank you thus far though with everything Paul - Your code is an absolutely fantastic help to me!

Kind Regards,
Paul, Ireland

Sorry about that. Change both instances of 'Shapes' to 'ShapeRange'.

Quote:

---

Originally Posted by macropod

Sorry about that. Change both instances of 'Shapes' to 'ShapeRange'.

---

That's no problem at all - it now works perfectly. I suppose there's no need for the error handling then because to be honest this was the only thing left :) I'm hesitating in asking this but for some reason one of the Word docs ended up Read Only when I tried to open it - it worked with opening via XML convertor but I just thought it was a bit strange. If you have any ideas please let me know. Thank you!

I don't believe the macro is responsible for any of your documents read-only status - the macro explicitly opens them as read-only (i.e. meaning it can't save changes to them) then explicitly closes them unchanged. Opening as read-only doesn't change their file attributes, though. The only reason I can see for a document becoming read-only is that it was already open - perhaps in an orphaned Word session. Since the macro runs Word in the background, it's possible there is an orphaned Word session from a previous crash. f you close Word then use Task Manager, you should be able to check whether there's a Word process still running. If so, killing it should resolve the problem.

Thanks Paul - I think the issue must have something to do with the fact our office uses Citrix and I can't access Task Manager to crash out open documents... Each time I log out of the Citrix I'm in Word asks if I want to save the changes on a few (not all) of the Word documents. It doesn't matter though because the code is utterly brilliant as it is and does exactly what I had asked for.

Thank you so much for taking the time to help me! Till the next time...:)

Kind regards,
Paul, Ireland

Hi Macropod,

I hope you are keeping well. FYI the code is working great - so much so that I've been asked by my boss if I could do something extra. If you feel this should be added under a new post then please advise but because it's the same code, just altered a bit, I hope it's ok tag onto this?

Compared to above this is much simpler I think, it's just that I'm stuck. Here's the code and below it is my question:

Code:

---

Sub UpdateFindingsData()
 
    Application.ScreenUpdating = False
    Dim wdApp As Object, wdDoc As Object, wdRng As Object
    Dim WkSht As Worksheet, LRow As Long, i As Long
    Dim strFldr As String, strFile As String, StrDoc As String
    Dim FSObj As Object, FSOFile As Object, DtTm As Date
    Set WkSht = ThisWorkbook.Sheets("Findings")
    Sheet5.Unprotect Password:="Secret"
    LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
    Set wdApp = CreateObject("Word.Application")
    If wdApp Is Nothing Then
        MsgBox "Can't start Word.", vbExclamation
        Exit Sub
    End If
    With WkSht
        For i = 1 To LRow
            If LCase(.Cells(i, 1).Text) = "true" Then
                strFldr = .Cells(i, 2).Text
                If Dir(strFldr, vbDirectory) = "" Then
                    .Cells(i, 3).Value = "Please check Folder Location"
                Else
                    If FSObj Is Nothing Then Set FSObj = CreateObject("Scripting.FileSystemObject")
                    'loop through each file and get date last modified. If largest date then store Filename
                    DtTm = DateSerial(1900, 1, 1)
                    strFile = Dir(strFldr & "\*.doc*", vbNormal)
                    While strFile <> ""
                        Set FSOFile = FSObj.GetFile(strFldr & "\" & strFile)
                        If FSOFile.DateLastModified > DtTm Then
                            DtTm = FSOFile.DateLastModified
                            StrDoc = strFldr & "\" & strFile
                        End If
                        strFile = Dir()
                    Wend
                    Set FSOFile = Nothing
                    Set wdDoc = wdApp.Documents.Open(Filename:=StrDoc, _
                    AddToRecentFiles:=False, Visible:=False, ReadOnly:=False)
                    With wdDoc
                    Application.CutCopyMode = False
                 
                        With .Range
                            With .Find
                                .ClearFormatting
                                .Replacement.ClearFormatting
                                .Forward = True
                                .Wrap = 0 'wdFindStop
                                .Format = True
                                .Style = "Heading 1"
                                .MatchWildcards = False
                                .MatchCase = False
                                .Text = "Findings^p"
                                .Replacement.Text = ""
                                .Execute
                            End With
                            If .Find.Found = True Then
                                Set wdRng = .Duplicate
                                wdRng.Collapse 0 'wdCollapseEnd
                            End If
                            .Start = wdRng.End
                            With .Find
                                .Text = "Appendices"
                                .Execute
                            End With
                            If .Find.Found = True Then
                                wdRng.End = .Duplicate.Start - 1
                            End If
                            If Not wdRng Is Nothing Then
                                With wdRng
                                   
                                    If .Tables.Count > 0 Then
                                 
                                        With WkSht
                                            Cells(i, 3) = Replace(Replace(wdDoc.Tables(2).Range.Text, Chr(13) & Chr(7) & Chr(13) & Chr(7), Chr(10)), Chr(13) & Chr(7), Space(4))
                                        End With
                                        Application.CutCopyMode = False
                                   
                                    End If
                                       
                                End With
                                Application.CutCopyMode = False
                            Else
                                WkSht.Cells(i, 3).Value = "Not Found"
                            End If
                        End With
                        .Close Savechanges:=False
                    End With
                    Set wdRng = Nothing
                End If
            End If
        Next
        .Columns(3).Cells.Replace What:="¶", Replacement:=Chr(10), _
        LookAt:=xlPart, SearchOrder:=xlByRows
        .Columns(3).WrapText = True
    End With
    wdApp.Quit
    Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
    Application.ScreenUpdating = True
 
    Sheet5.Protect Password:="Secret"
 
    MsgBox "Findings Data has been extracted successfully from the Documents"
 
End Sub

---

I'm sure you can see I'm now trying to take the table contents which is found between "Findings" and "Appendices" and put this table directly into one single Excel cell adjacent to the folder location. It works in so far as I reference the table number Tables(2) but I had hoped that the range would capture the specific table between the range because some of the Word Docs can have tables prior to this one. Would you be so kind and advise what I'm doing wrong please? Or perhaps is there a way in vba to take the first table below the Heading "Findings" and put into adjacent cell?

Thanks again Paul - I'll keep trying to fix this but I'm sure you'll figure it out before me so please let me know or point in the direction...

The problem is that you're specifying the wrong working range to locate the table. Instead of:

Code:

---

With WkSht
Cells(i, 3) = Replace(Replace(wdDoc.Tables(2).Range.Text, Chr(13) & Chr(7) & Chr(13) & Chr(7), Chr(10)), Chr(13) & Chr(7), Space(4))
End With

---

all you need is:

Code:

---

WkSht.Cells(i, 3) = Replace(Replace(.Tables(1).Range.Text, Chr(13) & Chr(7) & Chr(13) & Chr(7), Chr(10)), Chr(13) & Chr(7), Space(4))

---

I also can't see the point of all your 'Application.CutCopyMode = False' lines and, if 'Sheet5' is your "Findings" sheet, you should replace those references with 'WkSht'; otherwise, guess what will happen if someone re-orders the worksheets...

Thank you again Paul. Your line of code works perfectly.

The 'Application.CutCopyMode = False' lines were added when I was testing the code and I forgot to remove them - sorry for any confusion. And thanks for the tip on sheet name! The chances are high that someone down the line will try to add/edit sheets...

And now,,, with bated breath I hope it's not too much to ask but, well, here goes... In some (not all but quite a few) of the tables there are check-boxes - more specifically, when I double-click on the square shape inside the table Word pops up a window named "Checkbox Form Field Options" - and some check-boxes are Checked and some are Not Checked = I assume this translates to True/False? The resulting transfer in the Excel cell is this symbol:  (I don't know if this is displaying correctly but it's like an upside-down T, an up tack perhaps?)

The trouble is the up tack does not display differently whether the check box is checked or not. I don't think this is a formatting issue so I was wondering if it's possible for the code to replace the Checked or Not Checked with perhaps a symbol that Excel can read, like "X" & "Y"?

I hope I have explained my issue succinctly and if you have come across something like this before and might be able to help please let me know.

Thanks for all your help Paul - it's very very much appreciated

Quote:

---

The resulting transfer in the Excel cell is this symbol:  (I don't know if this is displaying correctly but it's like an upside-down T, an up tack perhaps?)

---

That's because .Range.Text gets just the 'text' of the range, but the checkbox formfields don't have text as such, just a true/false state. What you need to do, then, is to pre-process the table to convert all checkbox formfields to something meaningful (e.g. 1/0, TRUE/FALSE, CHECKED UNCHECKED). the simplest is 1/0:

Code:

---

Dim wdCell As Word.Cell, wdFmFld As Word.FormField
...
With wdRng                                     
If .Tables.Count > 0 Then
With .Tables(1)
For Each wdFmFld In .Range.FormFields
wdFmFld.Range.Text = wdFmFld.Result
Next
WkSht.Cells(i, 3) = Replace(Replace.Range.Text, Chr(13) & Chr(7) & Chr(13) & Chr(7), Chr(10)), Chr(13) & Chr(7), Space(4))
End With
End If
End With
... etc

---

This assumes, of course, the document's form protection is off when the macro is run.

Hi Paul, thanks for offering your help with this...

I just popped your code in (including the Dim...) but I'm getting a "Compile Error Expected: End of Statement" message and then the comma at Chr(10)), is highlighted blue. Is there maybe a change that can help at all please?

Cheers! You're an absolute legend for helping and knowing how to do all this!

Sorry, a bracket disappeared somehow!

Change:
WkSht.Cells(i, 3) = Replace(Replace.Range.Text, Chr(13) & Chr(7) & Chr(13) & Chr(7), Chr(10)), Chr(13) & Chr(7), Space(4))
to:
WkSht.Cells(i, 3) = Replace(Replace(.Range.Text, Chr(13) & Chr(7) & Chr(13) & Chr(7), Chr(10)), Chr(13) & Chr(7), Space(4))