Question

从此： excel data

我想在

中移动和设置内容样式

Word就是这样： Word document

使用VBA。

我成功识别出“组件”重复项，将其用作Word中的章节名称。但是现在，对我来说，困难的部分是选择仅与有关“组件”相关的“备件”，复制它们并粘贴它们。我知道如何打开Word，创建Word文档并粘贴到其中。但我只是在选择要粘贴的东西时被阻止了。

提前感谢您的建议。

Answer 1

以下代码会将Excel中的数据加载到2D数组中。首先确定阵列的尺寸，而不是将数据保存到阵列中。创建新的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

vba excel list to word with chapters

1 个答案: