使用vba在word中添加表

Question

我一直在尝试从数据库中添加单词表。

到目前为止，我在word文档中创建了一个表作为模板

然后我做的是将其复制到一个新的word文档中，搜索DT和Dokumenttype，然后用我想要的值替换它。这个速度很慢（但它看起来速度极快），直接在文字中创建它会更好。

创建表后，我开始向其添加行，其中第一列将被超链接。这似乎需要时间，11个表上只有235行总分，但创建11个表需要将近一分钟。所以我的问题是你们通常如何创建表格？

您是否创建了表格的标题，然后继续添加行？ 你是双循环，找到所需的行数，然后一次创建整个表？ 您是否将数组复制到表中以填充行？然后重新加载超链接第一列？ 输出如下：

以下是我目前的代码：

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