Word VBA, Collate values from multiple documents

[hypoid333]

I have a folder containing around 20 questionnaire documents. Each document contains an identical set of 3 tables with 7 columns. The first row and first column of each table are headers. The other cells contain letter Xs which the user has inserted in response to each question as shown in the example below.

In the same folder, I have an identical document called Results.doc. What I need is a macro that will loop through the 20 questionnaires, and for each X, find the matching cell address in Results.doc and add a 1 to it so it would look like the Results.doc example below. It should not matter if the X is upper or lowercase.

I only have a very basic knowledge of macros, and help from a VBA expert would be much appreciated.

Jim’s Questionnaire.doc
Table 1......Critical.....High.....Medium.....Low.....Negligible.....N/A
Q1..............................X...........................................................
Q2..........................................................X...............................

Table 2......Critical.....High.....Medium.....Low.....Negligible.....N/A
Q1............................................X.............................................
Q2.................X........................................................................
Q3.......................................................................................X..
Q4............................................X.............................................

Table 3......Critical.....High.....Medium.....Low.....Negligible.....N/A
Q1.........................................................................X................

=================================================

Results.doc
Table 1......Critical.....High.....Medium.....Low.....Negligible.....N/A
Q1.................3...........7.............3...........4..............2............1..
Q2.................5...........5.............2...........2..............6............0..

Table 2......Critical.....High.....Medium.....Low.....Negligible.....N/A
Q1.................9...........4.............5...........0..............0............2..
Q2.................1...........6.............0...........8..............4............1..
Q3.................4...........7.............3...........4..............0............2..
Q4.................2...........7.............1...........1..............3............6..

Table 3......Critical.....High.....Medium.....Low.....Negligible.....N/A
Q1.................3...........1.............6...........4..............5............1..

 

[fumei]

This can be done. What have you got so far?

55,687.00 hours down....
22 hours to go

tick-tick tick-tick tick-tick

 

[hypoid333]

Thank you so much for your reply Fumei. This is what I have so far. I'm afraid it's very rustic but does the job as far as looping through all the necessary table cells. But I don't know how to exclude Results.doc from the loop and I don't know how to add a 1 to the same cell address in Results.doc each time an X or x is found.

Sub Collate_Responses()
Dim strDocPath As String
Dim strCurDoc As String
Dim docCurDoc As Document
Dim i As Long
Dim tbl As Table
Dim oRw As Row
Dim cel As Cell

strDocPath = "C:\Data\"
strCurDoc = Dir(strDocPath & "*.doc")

Do While strCurDoc <> ""

'Results.doc needs to be open but at this stage I need
'something here to stop action on it. Something like:
'If Not FileName = "Results.doc"
Set docCurDoc = Documents.Open(FileName:=strDocPath & strCurDoc)
'End If

For i = 1 To ActiveDocument.Tables.Count
Set tbl = ActiveDocument.Tables(i)

For Each cel In ActiveDocument.Tables(i).Range.Cells
'Ignore headers in 1st row and 1st column of each table
If Not cel.RowIndex = 1 And Not cel.ColumnIndex = 1 Then
cel.Select
End If

'Here I need something like:
' If ActiveCell.Value = "X" Or "x" Then
' To the cell in Results.doc, which has the same cell address as ActiveCell,
' Add a 1 to the numerical value that is already in the cell in Results.doc
' End If

Next 'Cell
Next i 'Table

docCurDoc.Close wdDoNotSaveChanges

strCurDoc = Dir
Loop

End Sub

 

[fumei]

1. use more objects
2. use the objects you DO declare.

You declare and Set docCurDoc ...but then use ActiveDocument (not docCurdoc).

You declare and Set tbl...but then use ActiveDocument.Tables(i).

3. it would be MUCH easier if the total table in Results.doc had numbers not strings.

Try something like this. It converts the Results.doc table (ResultTable) cell contents to a number and adds 1.

Option Explicit
Function cellText(strIn As String) As String
' gets the cell text without end-of-cell marker
cellText = Left(strIn, Len(strIn) - 2)
End Function

Function IncrementMe(aCell As Cell, cellString As String) As Long
Dim j As Long
j = CLng(cellText(cellString))
IncrementMe = j + 1
End Function

Sub Collate_Responses()
Dim file
Dim strPath As String
Dim CellCounter As Long
Dim ResultsDoc As Document
Dim i As Long
Dim ResultTable As Table
Dim aCell As Cell

' this assumes Results.doc IS open!
Set ResultsDoc = Documents("Results.doc")
' set the proper index number!!
Set ResultTable = ResultsDoc.Tables(1)

strPath = "C:\Data\"
file = Dir(strPath & "*.doc")

Do While file <> ""
   Documents.Open FileName:=strDocPath & file
      For i = 1 To ActiveDocument.Tables.Count
         Set WorkingTable = ActiveDocument.Tables(i)
         For Each aCell In WorkingTable.Range.Cells
            CellCounter = CellCounter + 1
            'Ignore headers in 1st row and 1st column of each table
            If Not aCell.RowIndex = 1 And _
               Not aCell.ColumnIndex = 1 Then
               ' if  "X" or "x"
               If UCase(cellText(aCell.Range.Text)) = "X" Then
                   ResultTable.Range.Cells(CellCounter).Range.Text = _
                     IncrementMe(ResultTable.Range.Cells(CellCounter), _
                           ResultTable.Range.Cells(CellCounter).Range.Text)
               End If
            End If
         Next 'Cell
         CellCounter = 0
      Next i 'Table
   ActiveDocument.Close
   file = Dir()
Loop
End Sub

Sorry, I have not fully tested it, although I did test the individual Clng on cells. I am heading off-line in minutes (retiring) and so will not able to help further. If you have problems I am sure someone will be able to help you.

55,687.00 hours down....
<10 hours to go

tick-tick tick-tick tick-tick

 

[mintjulep]

Just cut and paste the tables into Excel.

They should come in nicely as cells.

Then a few simple COUNTIF() formulas and your done.