setalley
asked on
Split table above each Category
Thanks to the help of EE, I've got an export from Access to Word working great...with one exception. Currently, the code below extracts data from my Access query and creates a new report in Word. It's creating a single table where I'm shading each row that's a Category header.
What I need to have it do is split the table BEFORE each Category header...so that I end up with separate tables for each Category. I tried to apply some code I found on this site but I couldn't adapt it for my purposes:
objWord.Selection.SplitTab le
wrdRange.InsertBefore rsNarrative.Fields(0).Valu e & vbCrLf
Can anyone assist me, please? Thank you!
What I need to have it do is split the table BEFORE each Category header...so that I end up with separate tables for each Category. I tried to apply some code I found on this site but I couldn't adapt it for my purposes:
objWord.Selection.SplitTab
wrdRange.InsertBefore rsNarrative.Fields(0).Valu
Can anyone assist me, please? Thank you!
Option Compare Database
Private Sub cmdNewExport_Click()
Dim word 'the Word application
Dim doc 'the Word document
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sql As String
Set db = CurrentDb
Dim objTable As word.Table
Dim objRange As word.Range
sql = "SELECT tbl_WeeklyCategory.CategoryName, tbl_WeeklyUpdate.WeeklyUpdName, tbl_WeeklyUpdate.WeeklyUpdDes"
sql = sql & " FROM tbl_WeeklyUpdate INNER JOIN tbl_WeeklyCategory ON tbl_WeeklyUpdate.WCatID = tbl_WeeklyCategory.WCatID"
sql = sql & " ORDER BY tbl_WeeklyUpdate.WCatID, tbl_WeeklyUpdate.WeeklyUpdName;"
Set rs = db.OpenRecordset(sql)
Set word = CreateObject("word.application")
Set doc = word.Documents.Add
With word
.Visible = True
Set doc = .Documents.Open("c:\PDE_Weekly_Report.doc", , False)
End With
doc.GoTo what:=wdGoToBookmark, Name:="Start"
With word.Selection
.TypeText Text:="Pre-Development Evaluation Weekly Summary"
.TypeParagraph
.TypeText Text:="Week Ending "
doc.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"DATE \@ ""dddd d MMMM, yyyy"" ", PreserveFormatting:=True
.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
.MoveLeft Unit:=wdCharacter, Count:=33, Extend:=wdExtend
.Font.Bold = wdToggle
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.MoveDown Unit:=wdLine, Count:=1
.TypeParagraph
End With
doc.Tables.Add Range:=word.Selection.Range, NumRows:=1, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With doc.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(0.4)
.BottomMargin = InchesToPoints(0.4)
.LeftMargin = InchesToPoints(0.7)
.RightMargin = InchesToPoints(0.6)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
End With
With doc.Tables(1)
.Columns(1).SetWidth 100, wdAdjustNone
.Columns(2).SetWidth 400, wdAdjustNone
End With
With word.Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
While Not rs.EOF
If Not tmpCat = rs.Fields("CategoryName") Then
With word.Selection
.Style = ActiveDocument.Styles("Categories")
.Font.Size = 11
.SelectRow
.Shading.Texture = wdTextureNone
.Shading.ForegroundPatternColor = wdColorAutomatic
.Shading.BackgroundPatternColor = wdColorLightYellow
.TypeText Text:=rs.Fields("CategoryName").Value
.MoveRight Unit:=wdCell
.MoveRight Unit:=wdCell
End With
tmpCat = rs.Fields("CategoryName")
End If
With word.Selection
.Style = ActiveDocument.Styles("Projects")
.Font.Bold = wdToggle
.Font.Size = 11
.SelectRow
.Shading.Texture = wdTextureNone
.Shading.ForegroundPatternColor = wdColorAutomatic
.Shading.BackgroundPatternColor = wdColorWhite
.TypeText Text:=rs.Fields("WeeklyUpdName").Value
.MoveRight Unit:=wdCell
End With
With word.Selection
.Style = ActiveDocument.Styles("Desc")
.Font.Size = 11
.TypeText Text:=rs.Fields("WeeklyUpdDes").Value
.MoveRight Unit:=wdCell
End With
rs.MoveNext
Wend
word.Dialogs(wdDialogFileSaveAs).Show
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER