Solved

Split table above each Category

Posted on 2009-04-02
2
360 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
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

Comprehensive Backup Solutions for Microsoft

Acronis protects the complete Microsoft technology stack: Windows Server, Windows PC, laptop and Surface data; Microsoft business applications; Microsoft Hyper-V; Azure VMs; Microsoft Windows Server 2016; Microsoft Exchange 2016 and SQL Server 2016.

Question has a verified solution.

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

Suggested Solutions

Phishing attempts can come in all forms, shapes and sizes. No matter how familiar you think you are with them, always remember to take extra precaution when opening an email with attachments or links.
AutoNumbers should increment automatically, without duplicates.  But sometimes something goes wrong, and the next AutoNumber value is a duplicate.  This article shows how to recover from this problem.
Basics of query design. Shows you how to construct a simple query by adding tables, perform joins, defining output columns, perform sorting, and apply criteria.
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 …

685 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