Adding tables in word with vba - vba

Question

I have been experimenting with adding tables in word from database.
So far I made a table in word document as a template
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.
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?
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:
Below is my current 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=" & 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) <> previousDokType Then
If j > 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\" & projectNumber & 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 > 3 And k <> 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\" & prosjektnumber
'change permision if needed
If Dir(dirName, vbDirectory) = "" And Not Settings.debugMy Then
MkDir dirName
End If
'filename of docOut
docOutname = dirName & "\" & prosjektnumber & "-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