Solved

Split table above each Category

Posted on 2009-04-02
2
364 Views
Last Modified: 2012-05-06
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.SplitTable
wrdRange.InsertBefore rsNarrative.Fields(0).Value & vbCrLf

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

Open in new window

0
Comment
Question by:setalley
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
2 Comments
 
LVL 23

Accepted Solution

by:
irudyk earned 250 total points
ID: 24052611
From what I can tell from what you've posted, the following modified code should work:

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
                .SplitTable
                .MoveDown
                .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

Open in new window

0
 

Author Closing Comment

by:setalley
ID: 31565901
irudyk - That worked perfectly...thank you so much!
0

Featured Post

Instantly Create Instructional Tutorials

Contextual Guidance at the moment of need helps your employees adopt to new software or processes instantly. Boost knowledge retention and employee engagement step-by-step with one easy solution.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Access custom database properties are useful for storing miscellaneous bits of information in a format that persists through database closing and reopening.  This article shows how to create and use them.
This article describes a method of delivering Word templates for use in merging Access data to Word documents, that requires no computer knowledge on the part of the recipient -- the templates are saved in table fields, and are extracted and install…
What’s inside an Access Desktop Database. Will look at the basic interface, Navigation Pane (Database Container), Tables, Queries, Forms, Report, Macro’s, and VBA code.
In Microsoft Access, learn how to use Dlookup and other domain aggregate functions and one method of specifying a string value within a string. Specify the first argument, which is the expression to be returned: Specify the second argument, which …

738 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question