Help with tables using VBA (Code messing up)

[trezraven]

I am using Office 2007 and I have created a form that pulls
information from an Access database. My problem is the code works
fine for the first two records, but it gets jumbled up after that.
Below is a copy of my code.

Public blnCancelled As Boolean
Public rstart As Object
Public rend As Object
Private Sub btnCancel_Click()
Opinion.blnCancelled = True
Unload Me
End Sub

Private Sub btnGetData_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim lngConnectionState As Long
Dim strSQL As String
Dim Appellant As String
Dim Appellee As String
Dim OpinionDate As Date
Dim CaseNumber As String
Dim trange As Range
Dim ntable As Table
Dim rstart As Long
Dim rend As Long


'*****Set up the connection to the database*****
conn.ConnectionString = "Provider=MSDAORA; Data Source=TSD1; User
ID=Omitted for security; Password=Omitted for security"

'*****Open the connection to the database*****
conn.Open
Set rs = New ADODB.Recordset

'*****Check the state of the database*****
lngConnectionState = conn.State

'*****Set the datasource*****
strSQL = "Select Appellant, Appellee, Opinion_Date, CaseNo " & _
"From CMS.V_Macro4mandate " & _
"Where Opinion_Date = '" & txtOpinionDate & "' " & _
"Or CaseNo Like '" &
IIf(IsNull(Opinion.txtCaseNumber.Value), "*",
Opinion.txtCaseNumber.Value) & "'" & _
"Order by Appellant "

'*****Open the recordset*****
rs.Open strSQL, conn, adOpenKeyset, adLockOptimistic

'*****Get the data if not end of the recordset*****
If rs.EOF Then
MsgBox "No information in the database! Please verify your case number
or opinion date.", vbCritical, "ERROR!"
End If

rs.MoveFirst
If Not rs.EOF Then
Do Until rs.EOF
Opinion.txtAppellant = rs.Fields("Appellant").Value & " "
Opinion.txtAppellee = rs.Fields("Appellee").Value & " "
Opinion.txtCaseNumber = rs.Fields("CaseNo").Value & " "
Opinion.txtOpinionDate = rs.Fields("Opinion_Date").Value & " "

'*****Hide the form so the document can come up*****
Opinion.Hide

'****Insert table*****
Set trange = ActiveDocument.Range(rstart, rend)
trange.Select
trange.Collapse wdCollapseEnd

Set ntable = ActiveDocument.Tables.Add(Range:=trange, NumRows:=8,
NumColumns:=2, _
DefaultTableBehavior:=wdWord9TableBehavior,
AutoFitBehavior:=wdAutoFitFixed)

With ntable
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If

.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With

ntable.Rows.HeightRule = wdRowHeightAtLeast
ntable.Rows.Height = InchesToPoints(0.3)
ntable.Range.Font.AllCaps = True
ntable.Range.Font.Size = 14
ntable.Range.Font.Name = "Times New Roman"
ntable.Range.Cells(1).VerticalAlignment = wdCellAlignVerticalTop

With ntable
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderVertical).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders.Shadow = False
End With

'*****Add the formatting for the document*****
With trange
Selection.Range.ParagraphFormat.LineSpacingRule =
wdLineSpaceSingle
Selection.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
Selection.SelectRow
Selection.Range.Cells.Merge
Selection.TypeText Text:="case of " & txtAppellant.Value
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.SelectRow
Selection.Range.Cells.Merge
Selection.TypeText Text:="vs. " & txtAppellee.Value
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeText Text:="docket no. " & txtCaseNumber.Value
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="Opinion Filed " & txtOpinionDate.Value
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.SelectRow
Selection.Range.Cells.Merge
Selection.TypeText Text:="rehearing petition filed"
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.SelectRow
Selection.Range.Cells.Merge
Selection.TypeText Text:="rehearing denied"
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.SelectRow
Selection.Range.Cells.Merge
Selection.TypeText Text:="rehearing granted"
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.SelectRow
Selection.Range.Cells.Merge
Selection.TypeText Text:="released for publication"
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.SelectRow
Selection.TypeText Text:="date"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="Signed"
Selection.ClearParagraphAllFormatting
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
rs.MoveNext
End With
Loop
End If

rs.Close
conn.Close

'*****Search complete message*****
MsgBox "The seach is complete.", vbOKOnly

End Sub


This is the result once the code is ran.

CASE OF TONY J. WHITE
VS. STATE OF FLORIDA
DOCKET NO. 1D04-5296 OPINION FILED SEPTEMBER 29, 2005
REHEARING PETITION FILED
REHEARING DENIED
REHEARING GRANTED
RELEASED FOR PUBLICATION
DATE SIGNED



CASE OF TERRY HESTER
VS. STATE OF FLORIDA
DOCKET NO. 1D05-369 OPINION FILED SEPTEMBER 29, 2005
REHEARING PETITION FILED
REHEARING DENIED
REHEARING GRANTED
RELEASED FOR PUBLICATION
DATE SIGNED



DATE <<<<<This is out of order and is missing
information
SIGNED



DOCKET NO. 1D04-4934 OPINION FILED SEPTEMBER 29, 2005
REHEARING PETITION FILED
REHEARING DENIED
REHEARING GRANTED
RELEASED FOR PUBLICATION
DATE SIGNED



CASE OF MURL HOMISTER
VS. STATE OF FLORIDA
DOCKET NO. 1D04-5406 OPINION FILED SEPTEMBER 29, 2005
REHEARING PETITION FILED
REHEARING DENIED
REHEARING GRANTED
RELEASED FOR PUBLICATION
DATE SIGNED



CASE OF CHARLES S. BURCH
VS. STATE OF FLORIDA
DOCKET NO. 1D03-2106 OPINION FILED SEPTEMBER 29, 2005
REHEARING PETITION FILED
REHEARING DENIED
REHEARING GRANTED
RELEASED FOR PUBLICATION
DATE SIGNED

Any help will be greatly appreciated!!!

 

[Doug Robbins - Word MVP]

I would suggest that you re-write to code so that it uses the Range object
rather than the Selection object.

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP