Adding tables in word with vba
<p>I have been experimenting with adding tables in word from database.</p>

<p>So far I made a table in word document as a template</p>

<p><a href="https://i.stack.imgur.com/KHzHy.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/KHzHy.png" alt="Template table"></a>
Then what I do is that I copy it into a new word document, search for DT and Dokumenttype and then replace it with the value I want. This is properly slow(however it seems to go extremly fast)and it would propberly be better to create it directly in word.</p>

<p>After creating the table i start adding rows to it, where the first column is to be hyperlinked. This is what seems to take time, it is only 235 rows total split on 11 tables but it takes almost a minute to create the 11 tables. So my question is how does you folks normally creates tables?</p>

<p>Do you create the header of the table, then keep adding rows? 
Do you double loop, to find number of rows needed then create the whole table at one go?
Do you copy an array into the table to fill the rows? Then reloop to hyperlink the first column?
Output looks like this:</p>

<p><a href="https://i.stack.imgur.com/VoO2K.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/VoO2K.png" alt="Output"></a>
Below is my current code:</p>

<pre><code>Option Explicit


Public Sub createDocOut(projectNumber As String, Optional reloadDatabase As Boolean = False)

Dim docOutArray() As String
Dim previousDokType As String
Dim doc_ As Document
Dim i As Long
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim sPercentage As Double
Dim numOfRows As Long

'Application.ScreenUpdating = False
docOutArray = Post.helpRequest("http://proto-ls/wordin.asp?Dok4=" &amp; projectNumber)

If CPearson.IsArrayEmpty(docOutArray) Then
    MsgBox "No document registered in database!"
End If

numOfRows = UBound(docOutArray, 1)


' creates a new document if needed otherwise it opens it
Set doc_ = NEwDocOut.createDocOutDocument(projectNumber)

If CustomProperties.getValueFromProperty(doc_, "_DocumentCount") = numOfRows And reloadDatabase = False Then
    Application.ScreenUpdating = True
    Exit Sub
Else
    Selection.WholeStory
    Selection.Delete
End If

'We add number of rows to document
Call CustomProperties.createCustomDocumentProperty(doc_, "_DocumentCount", numOfRows)

j = 0
previousDokType = ""
For i = LBound(docOutArray, 1) To numOfRows

    'new table
    If docOutArray(i, 1) &lt;&gt; previousDokType Then
        If j &gt; 0 Then
            doc_.Tables(j).Select
            Selection.Collapse WdCollapseDirection.wdCollapseEnd
            Selection.MoveDown Unit:=wdLine, Count:=1
        End If
        j = j + 1
        m = 2


        Call NEwDocOut.addTable(doc_, docOutArray(i, 1), docOutArray(i, 2))

    End If

    'new row
    With doc_.Tables(j)
        .Rows(m).Select
        Selection.InsertRowsBelow (1)
        m = m + 1

        ' Hyper link the file
        ActiveDocument.Hyperlinks.Add Anchor:=.Cell(m, 1).Range, _
        Address:="z:\Prosjekt\" &amp; projectNumber &amp; docOutArray(i, 3), ScreenTip:="HyperLink To document", _
        TextToDisplay:=FileHandling.GetFilenameFromPath(docOutArray(i, 3))
        'loop through cells
        For k = 3 To UBound(docOutArray, 2)
        '                .Cell(m, k - 2).Range.Font.Bold = False
        '                .Cell(m, k - 2).Range.Font.name = "Times New Roman"
        '                .Cell(m, k - 2).Range.Font.Size = 10
            If k &gt; 3 And k &lt;&gt; 8 Then
                .Cell(m, k - 2).Range.Text = docOutArray(i, k)
            End If

            If k = 8 Then
                .Cell(m, k - 2).Range.Text = Format(replace(docOutArray(i, k), ".", "/"), "mm.dd.yyyy")
            End If
        Next k
    End With

    previousDokType = docOutArray(i, 1)

Next i

'Application.ScreenUpdating = True

End Sub

'**********************************************************************
' ****** CREATE NEW DOCUMENT OUT **************************************
'**********************************************************************
Function createDocOutDocument(prosjektnumber As String) As Document

Dim dirName As String
Dim docOutname As String

Set createDocOutDocument = Nothing

' Hvis directory \Dokumentstyring\PFK ikke eksisterer, lag dette
dirName = "z:\Prosjekt\" &amp; prosjektnumber

'change permision if needed
If Dir(dirName, vbDirectory) = "" And Not Settings.debugMy Then
  MkDir dirName
End If

'filename of docOut
docOutname = dirName &amp; "\" &amp; prosjektnumber &amp; "-Dokut.docx"

If FileHandling.doesFileExist(docOutname) Then
    If FileHandling.openDocument(docOutname, True, True) Then
        Set createDocOutDocument = ActiveDocument
        Exit Function
    End If
End If

'
' Add the tamplate for DocOut and save it to Doclist
'
Set createDocOutDocument = Documents.Add(Template:="Z:\Dokumentstyring\Config\DocOut.dotm", NewTemplate:=False)




createDocOutDocument.SaveAs filename:=docOutname

'Final check if document was created
If Not FileHandling.doesFileExist(docOutname) Then
    Set createDocOutDocument = Nothing
End If


End Function


Function addTable(doc_ As Document, category As String, description As String)
    doc_.Activate
    'Insert out table
    Selection.InsertFile filename:="Z:\Dokumentstyring\Config\Doklistut.docx", Range:="", _
    ConfirmConversions:=False, link:=False, Attachment:=False

    'Replace the DT with the category
     If Not searchAll(doc_, "DT", category) Then
         MsgBox "Failed to replace category in table"
     End If

    'Replace the Dokumenttype with the category
     If Not searchAll(doc_, "Dokumenttype", description) Then
         MsgBox "Failed to replace document type in table"
     End If
End Function
</code></pre>