Quinn
08-15-2006, 05:52 AM
All,
I am using Visual Basic to search through a document to glean information from certain tables. There are perhaps 150 tables.
My macro works fine but does not identify some of the cells in certain tables. I do not see what is different with the cell. attached is an example, the 2nd column in the first row is not being picked up?
(I've simplified the table greatly, I've removed all the other rows that do not have a problem) and further below is my code:
-there is one form and 21 labels, I can send the compiled macro if desired:
Tables:
Index #:
1
PDS # (Report Name)
2
Index #:
3
PDS # (Report Name)
4
'NARRATIVE: PROGRAM THAT TAKES STANDARD REPORT REQUIREMENTS
'TABLES IN WORD AND CONVERTS THEM INTO AN
'EXCEL SPREADSHEET.
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const HWND_TOPMOST = -1
Option Explicit
Private Sub Command1_Click()
Dim xlWB As Excel.Workbook
Dim xlApp As New Excel.Application
Dim xlWs As Excel.Worksheet
'OPEN NEW EXCEL WORKBOOK
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = Workbooks.Add()
Set xlWs = xlWB.Worksheets(1)
'GET NUMBER OF POPULATED DISPLAY TEXTBOXES
Dim NumTextLabel As Integer
Dim i As Integer
For i = 0 To 20
NumTextLabel = i - 1
If TextLabel(i).Text = "" Or TextLabel(i).Text = " " Then Exit For
NumTextLabel = i
Next i
'SET LABELS IN FIRST ROW OF WORKSHEET
Dim n As Integer
For n = 0 To NumTextLabel
xlWs.Cells(1, n + 1).Formula = TextLabel(n).Text
Next n
'FORMAT LABELS
With xlWs
.Rows(1).Font.Bold = True
.Rows(1).HorizontalAlignment = xlCenter
End With
'TURN ON ERROR CHECKING
On Error GoTo ErrorHandler
'SEARCH THROUGH OPEN WORD DOCUMENT
'GET NUMBER OF TABLES
Dim ntables As Integer
ntables = Word.ActiveDocument.Tables.Count
'IF THE DOCUMENT HAS NO TABLES, OUTPUT ERROR MESSAGE
If ntables = 0 Then
Err.Raise vbObjectError + 1
End If
'LOOP THROUGH EACH TABLE
Dim r As Long
Dim T As Integer
For r = 1 To ntables
'RESET VALUES FOR TEXT BOXES TO MISSING FOR EACH ITERATION
For T = 0 To NumTextLabel
Textbox(T).Text = ""
Next T
'BEGIN SEARCHING AND ASSIGNING VALUES TO TEXTBOX VARIABLES
Dim oRow As Row
Dim oCell As Cell
Dim lCellText As String
Dim FirstL As String
Dim Text As String
Dim TextLen As Integer
Dim vCellText As String
Dim LPopTable As Integer
'LOOP THROUGH EACH ROW IN THE TABLE
For Each oRow In Word.ActiveDocument.Tables(r).Rows
'LOOP THROUGH THE CELLS IN THE ROW
For Each oCell In oRow.Cells
'LOOP THROUGH TEXTBOX ENTRIES
For i = 0 To NumTextLabel
lCellText = oCell.Range 'GET CELL TEXT
lCellText = Left$(lCellText, Len(lCellText) - 2) 'REMOVE END OF CELL MARKERS
lCellText = Replace(lCellText, Chr(13), "") 'REMOVE CR
lCellText = Trim(lCellText) 'REMOVE LEADING SPACES
If Len(lCellText) > 1 Then
FirstL = Left(lCellText, 1) 'GET FIRST CHARACTER
Select Case FirstL
Case Chr(21) To Chr(127) 'IF A LETTER OR NUMBER, LEAVE
lCellText = lCellText
Case Else
lCellText = Right(lCellText, Len(lCellText) - 1) 'IF A END OF CELL CHAR, REMOVE
End Select
End If
Text = TextLabel(i).Text 'GET TEXTBOX TEXT
TextLen = Len(TextLabel(i).Text) 'GET LENGTH OF TEXTBOX TEXT
If Left(UCase(lCellText), TextLen) = _
Left(UCase(Text), TextLen) Then 'IF TEXTBOX = CELL THEN...
vCellText = oCell.Next.Range 'MOVE TO NEXT CELL IN ROW
vCellText = Left$(vCellText, Len(vCellText) - 2) 'REMOVE END OF CELL MARKER
vCellText = Replace(vCellText, Chr(13), " - ") ' REPLACE CR WITH DASH
vCellText = Replace(vCellText, Chr(9), " - ") 'REPLACE TAB WITH DASH
Textbox(i).Text = vCellText 'STORE VALUE IN INVISIBLE TEXTBOX
LPopTable = r 'INCREMENT COUNT OF LAST POPULATED ROW
Exit For 'NEXT ROW
Else: lCellText = ""
Text = ""
End If
Next i 'NEXT CELL
Next oCell
Next oRow
'PUT TEXTBOX VALUES INTO EXCEL
Dim Test As String
Dim OutLen As Integer
For T = 0 To NumTextLabel
If Textbox(T).Text <> "" Then
Test = Textbox(T).Text
OutLen = Len(Test)
If OutLen < 255 Then
'OUTPUT AS A FORMULA (TO PREVENT AUTOFORMATTING)
xlWs.Cells(r + 1, T + 1).Formula = "= " & Chr(34) & Test & Chr(34)
'IF LENGTH > 255, CAN'T OUTPUT AS FORMULA
Else: xlWs.Cells(r + 1, T + 1).Formula = Test
End If
Else: xlWs.Cells(r + 1, T + 1).Formula = Textbox(T).Text 'IF VALUE IS BLANK, DON'T OUTPUT AS FORMULA
End If
Next T
Next r
'DELETE ANY BLANK ROWS CAUSED BY OTHER TABLES IN THE DOC
Dim x As Integer
x = 1
If LPopTable > 1 Then
Do Until x = LPopTable
x = x + 1
'CHECK FIRST FIVE COLUMNS, IF ALL BLANK, DELETE ROW
If xlWs.Cells(x, 1).Formula = "" And xlWs.Cells(x, 2).Formula = "" _
And xlWs.Cells(x, 3).Formula = "" And xlWs.Cells(x, 4).Formula = "" _
And xlWs.Cells(x, 5).Formula = "" Then
xlWs.Rows(x).EntireRow.Delete
x = x - 1 'IF DELETED ROW, RECHECK SAME ROW # BECAUSE ALL ROWS MOVED UP
LPopTable = LPopTable - 1 'IF DELETED ROW, DECREASE ROW COUNT BY 1
End If
Loop
End If
'IF NO TABLES WERE OUTPUT TO EXCEL, OUTPUT ERROR
If xlWs.Cells(2, 1).Formula = "" And xlWs.Cells(2, 2).Formula = "" _
And xlWs.Cells(2, 3).Formula = "" And xlWs.Cells(2, 4).Formula = "" _
And xlWs.Cells(2, 5).Formula = "" _
Then Err.Raise vbObjectError + 2
'FORMAT CELL WIDTHS AFTER BEING POPULATED
Dim c As Integer
xlWs.Columns("A:U").EntireColumn.AutoFit
For c = 1 To 21
If xlWs.Columns(c).ColumnWidth > 50 Then
xlWs.Columns(c).ColumnWidth = 50
xlWs.Columns(c).WrapText = True
End If
Next c
xlWs.Rows("2:100").HorizontalAlignment = xlLeft
'ERRORS HANDLED HERE
ErrorHandler:
Dim ErrMsg As String
Dim ErrNum As Long
'MOVE FORM TO TOP
SetWindowPos Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, _
SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE
ErrNum = Err.Number
Select Case ErrNum
Case 429 'NO OPEN WORD DOCUMENT
ErrMsg = "Make sure the Word document is open."
MsgBox ErrMsg, , "Error"
Case vbObjectError + 1 'NO TABLES IN DOC OR TOO MANY DOCS OPEN
ErrMsg = "Either the open Word document has no tables or there are mulitple Word documents open. " & _
"Close or minimize all documents except the desired one."
MsgBox ErrMsg, , "Error"
Case vbObjectError + 2 'NO KEYWORDS IN TABLES
ErrMsg = "No tables with the necessary keywords were found in the document."
MsgBox ErrMsg, , "Error"
Case Else
End Select
End Sub
Private Sub TextLabel_GotFocus(Index As Integer)
Dim i As Integer
Dim oMyTextBox As Object
'SELECT TEXT WHEN TEXTBOX RECEIVES FOCUS
Set oMyTextBox = Screen.ActiveControl
If TypeName(oMyTextBox) = "TextBox" Then
i = Len(oMyTextBox.Text)
oMyTextBox.SelStart = 0
oMyTextBox.SelLength = i
End If
End Sub
I am using Visual Basic to search through a document to glean information from certain tables. There are perhaps 150 tables.
My macro works fine but does not identify some of the cells in certain tables. I do not see what is different with the cell. attached is an example, the 2nd column in the first row is not being picked up?
(I've simplified the table greatly, I've removed all the other rows that do not have a problem) and further below is my code:
-there is one form and 21 labels, I can send the compiled macro if desired:
Tables:
Index #:
1
PDS # (Report Name)
2
Index #:
3
PDS # (Report Name)
4
'NARRATIVE: PROGRAM THAT TAKES STANDARD REPORT REQUIREMENTS
'TABLES IN WORD AND CONVERTS THEM INTO AN
'EXCEL SPREADSHEET.
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const HWND_TOPMOST = -1
Option Explicit
Private Sub Command1_Click()
Dim xlWB As Excel.Workbook
Dim xlApp As New Excel.Application
Dim xlWs As Excel.Worksheet
'OPEN NEW EXCEL WORKBOOK
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = Workbooks.Add()
Set xlWs = xlWB.Worksheets(1)
'GET NUMBER OF POPULATED DISPLAY TEXTBOXES
Dim NumTextLabel As Integer
Dim i As Integer
For i = 0 To 20
NumTextLabel = i - 1
If TextLabel(i).Text = "" Or TextLabel(i).Text = " " Then Exit For
NumTextLabel = i
Next i
'SET LABELS IN FIRST ROW OF WORKSHEET
Dim n As Integer
For n = 0 To NumTextLabel
xlWs.Cells(1, n + 1).Formula = TextLabel(n).Text
Next n
'FORMAT LABELS
With xlWs
.Rows(1).Font.Bold = True
.Rows(1).HorizontalAlignment = xlCenter
End With
'TURN ON ERROR CHECKING
On Error GoTo ErrorHandler
'SEARCH THROUGH OPEN WORD DOCUMENT
'GET NUMBER OF TABLES
Dim ntables As Integer
ntables = Word.ActiveDocument.Tables.Count
'IF THE DOCUMENT HAS NO TABLES, OUTPUT ERROR MESSAGE
If ntables = 0 Then
Err.Raise vbObjectError + 1
End If
'LOOP THROUGH EACH TABLE
Dim r As Long
Dim T As Integer
For r = 1 To ntables
'RESET VALUES FOR TEXT BOXES TO MISSING FOR EACH ITERATION
For T = 0 To NumTextLabel
Textbox(T).Text = ""
Next T
'BEGIN SEARCHING AND ASSIGNING VALUES TO TEXTBOX VARIABLES
Dim oRow As Row
Dim oCell As Cell
Dim lCellText As String
Dim FirstL As String
Dim Text As String
Dim TextLen As Integer
Dim vCellText As String
Dim LPopTable As Integer
'LOOP THROUGH EACH ROW IN THE TABLE
For Each oRow In Word.ActiveDocument.Tables(r).Rows
'LOOP THROUGH THE CELLS IN THE ROW
For Each oCell In oRow.Cells
'LOOP THROUGH TEXTBOX ENTRIES
For i = 0 To NumTextLabel
lCellText = oCell.Range 'GET CELL TEXT
lCellText = Left$(lCellText, Len(lCellText) - 2) 'REMOVE END OF CELL MARKERS
lCellText = Replace(lCellText, Chr(13), "") 'REMOVE CR
lCellText = Trim(lCellText) 'REMOVE LEADING SPACES
If Len(lCellText) > 1 Then
FirstL = Left(lCellText, 1) 'GET FIRST CHARACTER
Select Case FirstL
Case Chr(21) To Chr(127) 'IF A LETTER OR NUMBER, LEAVE
lCellText = lCellText
Case Else
lCellText = Right(lCellText, Len(lCellText) - 1) 'IF A END OF CELL CHAR, REMOVE
End Select
End If
Text = TextLabel(i).Text 'GET TEXTBOX TEXT
TextLen = Len(TextLabel(i).Text) 'GET LENGTH OF TEXTBOX TEXT
If Left(UCase(lCellText), TextLen) = _
Left(UCase(Text), TextLen) Then 'IF TEXTBOX = CELL THEN...
vCellText = oCell.Next.Range 'MOVE TO NEXT CELL IN ROW
vCellText = Left$(vCellText, Len(vCellText) - 2) 'REMOVE END OF CELL MARKER
vCellText = Replace(vCellText, Chr(13), " - ") ' REPLACE CR WITH DASH
vCellText = Replace(vCellText, Chr(9), " - ") 'REPLACE TAB WITH DASH
Textbox(i).Text = vCellText 'STORE VALUE IN INVISIBLE TEXTBOX
LPopTable = r 'INCREMENT COUNT OF LAST POPULATED ROW
Exit For 'NEXT ROW
Else: lCellText = ""
Text = ""
End If
Next i 'NEXT CELL
Next oCell
Next oRow
'PUT TEXTBOX VALUES INTO EXCEL
Dim Test As String
Dim OutLen As Integer
For T = 0 To NumTextLabel
If Textbox(T).Text <> "" Then
Test = Textbox(T).Text
OutLen = Len(Test)
If OutLen < 255 Then
'OUTPUT AS A FORMULA (TO PREVENT AUTOFORMATTING)
xlWs.Cells(r + 1, T + 1).Formula = "= " & Chr(34) & Test & Chr(34)
'IF LENGTH > 255, CAN'T OUTPUT AS FORMULA
Else: xlWs.Cells(r + 1, T + 1).Formula = Test
End If
Else: xlWs.Cells(r + 1, T + 1).Formula = Textbox(T).Text 'IF VALUE IS BLANK, DON'T OUTPUT AS FORMULA
End If
Next T
Next r
'DELETE ANY BLANK ROWS CAUSED BY OTHER TABLES IN THE DOC
Dim x As Integer
x = 1
If LPopTable > 1 Then
Do Until x = LPopTable
x = x + 1
'CHECK FIRST FIVE COLUMNS, IF ALL BLANK, DELETE ROW
If xlWs.Cells(x, 1).Formula = "" And xlWs.Cells(x, 2).Formula = "" _
And xlWs.Cells(x, 3).Formula = "" And xlWs.Cells(x, 4).Formula = "" _
And xlWs.Cells(x, 5).Formula = "" Then
xlWs.Rows(x).EntireRow.Delete
x = x - 1 'IF DELETED ROW, RECHECK SAME ROW # BECAUSE ALL ROWS MOVED UP
LPopTable = LPopTable - 1 'IF DELETED ROW, DECREASE ROW COUNT BY 1
End If
Loop
End If
'IF NO TABLES WERE OUTPUT TO EXCEL, OUTPUT ERROR
If xlWs.Cells(2, 1).Formula = "" And xlWs.Cells(2, 2).Formula = "" _
And xlWs.Cells(2, 3).Formula = "" And xlWs.Cells(2, 4).Formula = "" _
And xlWs.Cells(2, 5).Formula = "" _
Then Err.Raise vbObjectError + 2
'FORMAT CELL WIDTHS AFTER BEING POPULATED
Dim c As Integer
xlWs.Columns("A:U").EntireColumn.AutoFit
For c = 1 To 21
If xlWs.Columns(c).ColumnWidth > 50 Then
xlWs.Columns(c).ColumnWidth = 50
xlWs.Columns(c).WrapText = True
End If
Next c
xlWs.Rows("2:100").HorizontalAlignment = xlLeft
'ERRORS HANDLED HERE
ErrorHandler:
Dim ErrMsg As String
Dim ErrNum As Long
'MOVE FORM TO TOP
SetWindowPos Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, _
SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE
ErrNum = Err.Number
Select Case ErrNum
Case 429 'NO OPEN WORD DOCUMENT
ErrMsg = "Make sure the Word document is open."
MsgBox ErrMsg, , "Error"
Case vbObjectError + 1 'NO TABLES IN DOC OR TOO MANY DOCS OPEN
ErrMsg = "Either the open Word document has no tables or there are mulitple Word documents open. " & _
"Close or minimize all documents except the desired one."
MsgBox ErrMsg, , "Error"
Case vbObjectError + 2 'NO KEYWORDS IN TABLES
ErrMsg = "No tables with the necessary keywords were found in the document."
MsgBox ErrMsg, , "Error"
Case Else
End Select
End Sub
Private Sub TextLabel_GotFocus(Index As Integer)
Dim i As Integer
Dim oMyTextBox As Object
'SELECT TEXT WHEN TEXTBOX RECEIVES FOCUS
Set oMyTextBox = Screen.ActiveControl
If TypeName(oMyTextBox) = "TextBox" Then
i = Len(oMyTextBox.Text)
oMyTextBox.SelStart = 0
oMyTextBox.SelLength = i
End If
End Sub