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

[pk247]

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

[macropod]

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/showthread.php?42850-Import-text-from-word-document-into-excel

[pk247]

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

[macropod]

You could use a macro like the following:

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.

[pk247]

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

[macropod]

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.

[pk247]

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

[macropod]

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:


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


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


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.

**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.

[pk247]

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

[pk247]

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

[macropod]

Try:

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.

[pk247]

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

[pk247]

Hi Paul,

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

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):



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

[macropod]

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

[pk247]

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

[pk247]

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!

[macropod]

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.

[pk247]

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

[pk247]

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:


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...

[macropod]

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

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:

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...

[pk247]

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

[macropod]

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:

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.

[pk247]

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!

[macropod]

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))