Extracting the text from a cell with a certain color

[jic]

Greetings and salutations.

I have a task to extract the text from a word document that is
contained within a colored cell. There are about 10 word documents
and each document has 60 through 100 tables and each table have one or
two cells with these colored cells.

Is there a way to look for a colored cell, say light green, and
extract the text in that cell?

I will really appreciate it.

thanks,

josé

 

[David Sisson]

I had trouble with the color. Even though I specified wdLightGreen,
the underlying value did not match, so I snooped the color and hard
coded it.

Maybe someone could comment about it.

Sub OpenAllFiles()
'Open all files in folder
'If Lightgreen background color found in cells,
'write data to new document.
Dim wdDoc As Document
Dim NewDoc As Document
Dim oTable As Table
Dim oCell As Cell

'Turn off screen updating.
Application.ScreenUpdating = False

'Change to the folder path.
strPath = ActiveDocument.Path

'Add a new document to collect data.
Set NewDoc = Documents.Add

Set scrFso = _
CreateObject("scripting.filesystemobject")
Set scrFolder = scrFso.getfolder(strPath)
For Each scrFile In scrFolder.Files

'the name of this file
strName = scrFile.Name

'the status bar is just to let us know where we are
Application.StatusBar = strPath & "\" & strName

'we'll open the file fName if it is a word document
If Right(strName, 4) = ".doc" Or Right(strName, 4) = ".docx"
Then
Set wdDoc = Documents.Open(FileName:=strPath & "\" &
strName, _
ReadOnly:=False,
Format:=wdOpenFormatAuto)
For Each oTable In ActiveDocument.Tables
For Each oCell In oTable.Range.Cells
'Debug.Print oCell.Shading.BackgroundPatternColor
If oCell.Shading.BackgroundPatternColor = 5296274
Then
NewDoc.Range.InsertAfter _
Left(oCell.Range.Text, _
Len(oCell.Range.Text) - 2) _
& vbCr
End If
Next oCell
Next oTable

'we close not saving changes
wdDoc.Close wdDoNotSaveChanges

End If
Next

'return control of status bar to Word
Application.StatusBar = False

Application.ScreenRefresh
Application.ScreenUpdating = True
End Sub

 

[jic]

I had trouble with the color.  Even though I specified wdLightGreen,
the underlying value did not match, so I snooped the color and hard
coded it.

Maybe someone could comment about it.

Sub OpenAllFiles()
'Open all files in folder
'If Lightgreen background color found in cells,
'write data to new document.
Dim wdDoc As Document
Dim NewDoc As Document
Dim oTable As Table
Dim oCell As Cell

'Turn off screen updating.
Application.ScreenUpdating = False

'Change to the folder path.
strPath = ActiveDocument.Path

'Add a new document to collect data.
Set NewDoc = Documents.Add

   Set scrFso = _
       CreateObject("scripting.filesystemobject")
    Set scrFolder = scrFso.getfolder(strPath)
    For Each scrFile In scrFolder.Files

        'the name of this file
        strName = scrFile.Name

        'the status bar is just to let us know where we are
        Application.StatusBar = strPath & "\" & strName

        'we'll open the file fName if it is a word document
        If Right(strName, 4) = ".doc" Or Right(strName, 4) = ".docx"
Then
            Set wdDoc = Documents.Open(FileName:=strPath & "\" &
strName, _
                                ReadOnly:=False,
Format:=wdOpenFormatAuto)
            For Each oTable In ActiveDocument.Tables
                For Each oCell In oTable.Range.Cells
                    'Debug.Print oCell.Shading.BackgroundPatternColor
                    If oCell.Shading.BackgroundPatternColor = 5296274
Then
                        NewDoc.Range.InsertAfter _
                            Left(oCell.Range.Text, _
                                Len(oCell..Range.Text) - 2) _
                                    &vbCr
                    End If
                Next oCell
            Next oTable

            'we close not saving changes
            wdDoc.Close wdDoNotSaveChanges

        End If
    Next

    'return control of status bar to Word
    Application.StatusBar = False

Application.ScreenRefresh
Application.ScreenUpdating = True
End Sub

thanks. This works great. I have one more question: The text that I
am extracting, I am placing into an excel sheet and the formatting
that is in Word is not the same in excel. The new lines disappear.
Any ideas as to why? Also, the same text from Excel imports fine in
the same word cell, which means that is just a display problem in
Excel. For example I extract this text from one of the Word cells:
Hi there.
I am here.
You are there

and in Excel the cell display:

Hi there.I am here.You are there

but when I import that same excel cell into the same word cell, the
word cell has,
Hi there.
I am here.
You are there

so the export and import of data is correct, but the display is not.

Any thoughts? Again, thanks for your help.

josé