vba excel列表到带有章节的单词

Question

来自：

我想移动内容并设置样式

这样写：

使用 VBA。

我成功识别了“组件”重复项，以将其用作 Word 中的章节名称。但是现在，对我来说，困难的部分是选择仅与相关“组件”相关的“备件”，复制并粘贴它们。我知道如何打开 Word、创建 Word 文档并粘贴到其中。但我只是无法选择要粘贴的正确内容。

提前感谢您的建议。

Answer 1

以下代码会将数据从 Excel 加载到二维数组中。首先确定数组的维度，然后将数据保存到数组中。创建新的 Word 文档，并将数组中的数据保存到 Word 文件中。数组中的每个第一项都保存为新段落，其他数据保存在表中。没有进行 Word 格式设置。

Option Base 1
Option Explicit
Sub TwoD_Tbl_to_Word()
    Dim MyArr() As String
    Dim comidx As Long
    Dim partidx As Long
    Dim partidxtmp As Long
    Dim i As Long
    Dim teststr As String

    Dim objWd As Word.Application
    Dim objDoc As Word.Document
    Dim myRange As Word.Range

    teststr = Cells(5, 2)
    comidx = 1
    partidx = 1
    partidxtmp = 1

'detect 2D Array Indexes
    For i = 6 To ActiveSheet.Columns("B").Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
        If Cells(i, 2) = teststr Then
            partidxtmp = partidxtmp + 1
        Else
        teststr = Cells(i, 2)
        If partidxtmp > partidx Then
            partidx = partidxtmp
        End If
        partidxtmp = 1
        comidx = comidx + 1
        End If
    Next i

'if the last item is the biggest
    If partidxtmp > partidx Then
        partidx = partidxtmp
    End If
'redefine array
    ReDim MyArr(comidx, partidx + 1)

'load Excel into Array
    teststr = Cells(5, 2)
    MyArr(1, 1) = Cells(5, 2)
    MyArr(1, 2) = Cells(5, 3)
    partidxtmp = 2
    comidx = 1

    For i = 6 To ActiveSheet.Columns("B").Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
        If Cells(i, 2) = teststr Then
           partidxtmp = partidxtmp + 1
           MyArr(comidx, partidxtmp) = Cells(i, 3)
        Else
           comidx = comidx + 1
           teststr = Cells(i, 2)
           MyArr(comidx, 1) = Cells(i, 2)
           MyArr(comidx, 2) = Cells(i, 3)
           partidxtmp = 2
        End If
    Next i
'Create Word
    Set objWd = CreateObject("word.application")
    objWd.Visible = True
    Set objDoc = objWd.Documents.Add

    For i = 1 To UBound(MyArr, 1)
        objWd.Selection.EndKey Unit:=wdStory
        objWd.Selection.TypeText Text:=i & ". " & MyArr(i, 1)
        objWd.Selection.TypeParagraph
        Set myRange = objWd.Selection.Range
        partidx = 1
'number of rows in Word table
        For partidxtmp = 2 To UBound(MyArr, 2)
            If Not MyArr(i, partidxtmp) = vbNullString Then
                partidx = partidx + 1
            End If
        Next partidxtmp

        objDoc.Tables.Add Range:=myRange, NumRows:=partidx - 1, NumColumns:=1

        For partidxtmp = 1 To partidx - 1
            objDoc.Tables(i).Cell(partidxtmp, 1).Range.Text = MyArr(i, partidxtmp + 1)
        Next partidxtmp

        Set myRange = objDoc.Tables(i).Range
        myRange.EndOf wdStory, wdMove
        myRange.InsertAfter vbCr
    Next i

    Set objDoc = Nothing
    Set objWd = Nothing

End Sub