Solved

Create bookmarks in the only table of the active document using VBA

Posted on 2014-01-11
8
417 Views
Last Modified: 2014-01-12
Dear Experts:

I got a 2 column table in the currently active document. The number of rows can vary from
1 to n rows depending on the currently active document.

I would like to run a macro that ...
... creates bookmarks of the cell values in the second column of the only table in the currently active document.
... The macro is to run thru the table from top to bottom. The bookmarks are to be named:

bookmark_01
bookmark_02
bookmark_03
bookmark_nn

Example sample table

Column 1    Column 2

17                Surgery Department
13                Oncology Department
18                Pediatrics Department

So the following bookmarks should be created

bookmark_01 = Range of Text marked by the bookmark: Surgery Department
bookmark_02 = Range of Text marked by the bookmark: Oncology Department
bookmark_03 = Range of Text marked by the bookmark: Pediatrics Department

The range of text marked by the bookmark is not to include the cell end marker

Help is much appreciated, thank you very much in advance.

Regards, Andreas
0
Comment
Question by:AndreasHermle
  • 3
  • 3
  • 2
8 Comments
 
LVL 35

Expert Comment

by:Robert Schutt
Comment Utility
I'm not sure why you specifically do not want to bookmark the whole cell but I think this is what you need, step through it to see what happens with the selection.
Sub macroAddBookmarks()
    With ActiveDocument.Tables(1)
        Dim rw As Long
        For rw = 1 To .Rows.Count
            .Rows(rw).Cells(2).Select
            Selection.MoveLeft wdCharacter, 1, wdExtend
            ActiveDocument.Bookmarks.Add "bookmark_" & Format(rw, "00"), Selection.Range
        Next
    End With
End Sub

Open in new window

If the list is long, you could use Application.ScreenUpdating to make the macro run faster.
0
 
LVL 76

Assisted Solution

by:GrahamSkan
GrahamSkan earned 250 total points
Comment Utility
Robert Schutt's suggestion might be  perfectly acceptable, however here is a version that does not use the Selection object and is more specific as regards referenced objects:
Sub AddBookmarks()
    Dim tbl As Table
    Dim rw As Row
    Dim rng As Range
    Dim bmk As Bookmark
    Dim cl As Cell
    Dim doc As Document
    
    Set doc = ActiveDocument
    Set tbl = doc.Tables(1)
    
    For Each rw In tbl.Rows
        Set cl = rw.Cells(2)
        Set rng = GetCellTextRange(cl)
        strBookmarkName = "bookmark_" & Format(cl.RowIndex, "00")
        Set bmk = doc.Bookmarks.Add(strBookmarkName, rng)
    Next rw
End Sub
Function GetCellTextRange(cl As Word.Cell) As Range
    Dim rng As Range
    
    Set rng = cl.Range
    rng.MoveEnd wdCharacter, -1
    Set GetCellTextRange = rng
End Function

Open in new window

0
 

Author Comment

by:AndreasHermle
Comment Utility
Dear Robert and Graham,

thank you very much for your professional help. Both codes work just fine although I have to admit that Graham's code is more elegant since it does not use the selection object.

There is one thing I would like to get tweaked. There are cases where the only table in the document has column headers hence in these cases ...
the bookmarks should only be created from row two (2) down to the last row  (in the second column) with the first bookmark still being named 'bookmark_01'

Help is much appreciated. Thank you very much in advance.

Regards, Andreas
0
 
LVL 76

Expert Comment

by:GrahamSkan
Comment Utility
This will omit the heading rows:
Sub AddBookmarks()
    Dim tbl As Table
    Dim rw As Row
    Dim rng As Range
    Dim bmk As Bookmark
    Dim cl As Cell
    Dim doc As Document
    
    Set doc = ActiveDocument
    Set tbl = doc.Tables(1)
    
    For Each rw In tbl.Rows
        If Not rw.HeadingFormat Then
            Set cl = rw.Cells(2)
            Set rng = GetCellTextRange(cl)
            strBookmarkName = "bookmark_" & Format(cl.RowIndex, "00")
            Set bmk = doc.Bookmarks.Add(strBookmarkName, rng)
        End If
    Next rw
End Sub

Open in new window

0
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 
LVL 35

Accepted Solution

by:
Robert Schutt earned 250 total points
Comment Utility
Graham, I'm using an old version of Word so I'm not sure if that's causing it but for me, after setting a repeating header row, cl.RowIndex returns 2 for the first data row so the bookmarks are not created starting with 1 anymore.

This gave me 2 ideas for additions:
1) skip empty rows
2) delete existing bookmarks as the macro could possibly be run again later with other data and the bookmarks would get out of order.

Andreas, if you are using a different way to designate header rows, please describe or post an example.

The 2 additions made in the code from the previous post:
Option Explicit

Const C_BOOKMARK_PREFIX = "bookmark_"

' solution by GrahamSkan
Sub AddBookmarks()
    Dim tbl As Table
    Dim rw As Row
    Dim rng As Range
    Dim bmk As Bookmark
    Dim cl As Cell
    Dim doc As Document
    Dim strBookmarkName As String
    
    ' added: id for bookmark
    Dim id As Long
    
    Set doc = ActiveDocument
    
    ' added: remove existing bookmarks we added earlier
    For id = doc.Bookmarks.Count To 1 Step -1
        If Left(doc.Bookmarks(id).Name, Len(C_BOOKMARK_PREFIX)) = C_BOOKMARK_PREFIX Then
            doc.Bookmarks(id).Delete
        End If
    Next
    id = 0
    
    Set tbl = doc.Tables(1)
    
    For Each rw In tbl.Rows
        If Not rw.HeadingFormat Then
            Set cl = rw.Cells(2)
            Set rng = GetCellTextRange(cl)
            If Len(rng.Text) > 0 Then
                id = id + 1
                strBookmarkName = C_BOOKMARK_PREFIX & Format(id, "00")
                Set bmk = doc.Bookmarks.Add(strBookmarkName, rng)
            End If
        End If
    Next rw
End Sub
Function GetCellTextRange(cl As Word.Cell) As Range
    Dim rng As Range
    
    Set rng = cl.Range
    rng.MoveEnd wdCharacter, -1
    Set GetCellTextRange = rng
End Function

Open in new window

tst2.doc
0
 
LVL 76

Expert Comment

by:GrahamSkan
Comment Utility
Robert,
Your version runs OK in Word 2003 and in Word 2007 on my Win 7 system
0
 

Author Comment

by:AndreasHermle
Comment Utility
Dear both,

thank you very much for your quick and professional help.

Robert, nice tweaking of Graham's code. Yes you are right, with Graham's tweaked code the bookmarks do not start with _01 anymore, but by changing line 16 on Graham's code (see below) the numbering is fine again (adding -1). I am sure it  was just an oversight on Graham's part.  

Line 16: strBookmarkName = "bookmark_" & Format(cl.RowIndex - 1, "00")

I also tweaked your first code on line 4 and 7 to get the desired result.

Sub macroAddBookmarks_Robert_tweaked_by_Andreas_Hermle()
    With ActiveDocument.Tables(1)
        Dim rw As Long
        For rw = 2 To .Rows.Count
            .Rows(rw).Cells(2).Select
            Selection.MoveLeft wdCharacter, 1, wdExtend
            ActiveDocument.Bookmarks.Add "bookmark_" & Format(rw - 1, "00"), Selection.Range
        Next
    End With
End Sub

Open in new window


Nevertheless you did a very fine job on tweaking Graham's code. I am aware that the following property of the first row, the header row, must be set as follows: Repeat as header row at top of each page. Otherwise the codes will not work.

I suggest splitting the points 50:50 because both of you contributed major parts.

thank you very much for your great help. I really appreciate it.

Regards, Andreas
0
 

Author Closing Comment

by:AndreasHermle
Comment Utility
Great job from both of you. Regards, Andreas
0

Featured Post

A Knowledge Base That Stays Up-to-Date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Do you ever need to create a 20 page Word document for some testing purpose? Are you tired of copying & pasting old boring "lorem ipsum" text over and over again, increasing font size and line space in order to make the document 20+ pages long? Look…
I'm writing to share my clumsy experience in using this elegant tool so you can avoid every stupid mistake I made. (I leave it to the authorities to decide if this deserves a place in the Knowledge archives.)  Now that I am on the other side of my l…
Office 365 is currently available in five editions. Three of them are for business use: Office 365 Business Essentials, Office 365 Business, and Office 365 Business Premium. Two of them are for home/personal use: Office 365 Home and Office 365 Perso…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

762 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

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now