Vba 每个唯一单元格一个word文档

我有如下excel表格：

A列| B列| C列

苹果

X鲍勃香蕉

梨

莎拉苹果

莎拉猕猴桃

Z卡尔香蕉

菠萝

西瓜

卡尔猕猴桃

我希望能够在A列中循环，对于每个唯一的A列值，生成一个word文档，B列中的值作为文档名称，C列作为内容。在上表中，一份名为“Bob”的文件包含“苹果香蕉梨”，另一份名为“Sarah”的文件包含“苹果猕猴桃”，第三份名为“Carl”的文件包含“香蕉菠萝西瓜猕猴桃”

我找到了代码，我根据自己的情况对其进行了调整，它可以将Excel中的所有内容复制并粘贴到word文档中，但这正是我所遇到的问题。不同的excel文档有不同的行数，一次是A列中的X，Y，Z，另一次是V，W，X，Y，Z。我知道我需要从X=1循环到Len（单元格（X，1））=0，但我不知道如何应用它。如果您能为我的小问题提供帮助，我将不胜感激，并有兴趣了解和理解您的原因。 一如既往地谢谢你。代码：

Option Explicit


Sub DataToWord()


Dim rng As Range 
Dim wdApp As Object 
Dim wdDoc As Object 
Dim t As Word.Range 
Dim myWordFile As String 
Dim x As Long

'initialize the Word template path
'here, it's set to be in the same directory as our source workbook
myWordFile = ThisWorkbook.Path & "\Document.dotx"

'get the range of the contiguous data from Cell A1
Set rng = Range("A1").CurrentRegion
'you can do some pre-formatting with the range here
rng.HorizontalAlignment = xlCenter 'center align the data
rng.Copy 'copy the range

Set wdApp = CreateObject("Word.Application")
'open a new word document from the template
Set wdDoc = wdApp.Documents.Add(myWordFile)

Set t = wdDoc.Content 'set the range in Word
t.Paste 'paste in the table
With t 'working with the table range
'we can use the range object to do some more formatting
'here, I'm matching the table with using the Excel range's properties
.Tables(1).Columns.SetWidth (rng.Width / rng.Columns.Count), wdAdjustSameWidth
End With

'until now the Word app has been a background process
wdApp.Visible = True
'we could use the Word app object to finish off
'you may also want to things like generate a filename and save the file
wdApp.Activate


End Sub

---

我相信这应该满足你的要求：

Option Explicit


Sub DataToWord()

    Dim rng As Range
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim t As Word.Range
    Dim myWordFile As String
    Dim x As Long

    'initialize the Word template path
    'here, it's set to be in the same directory as our source workbook
    myWordFile = ThisWorkbook.Path & "\Document.dotx"

    'Define the exclusive values of column A
    Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).Copy
    Range("E1").PasteSpecial
    Range(Range("E1"), Range("E" & Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo


    Set wdApp = CreateObject("Word.Application")

    'Inserts row necessary for autofilter, since the table has no headers
    Rows(1).Insert

    Dim excValue As Range
    For Each excValue In Range(Range("E2"), Range("E" & Rows.Count).End(xlUp))

        'Copies the data for that specific value
        Range(Range("A1"), Range("C" & Rows.Count).End(xlUp)).AutoFilter Field:=1, Criteria1:=excValue
        Range(Range("C2"), Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy

        'open a new word document from the template
        Set wdDoc = wdApp.Documents.Add(myWordFile)

        Set t = wdDoc.Content 'set the range in Word
        t.Paste 'paste in the table
        With t 'working with the table range
        'we can use the range object to do some more formatting
        'here, I'm matching the table with using the Excel range's properties
        .Tables(1).Columns.SetWidth (Range("C1").Width), wdAdjustSameWidth
        End With

        Dim name As String
        name = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)(1).Value
        wdDoc.SaveAs Filename:=ThisWorkbook.Path & "\" & name & ".docx"

    Next excValue

    'Deletes the inserted row
    Rows(1).Delete
    'Clear the column E
    Columns("E").Clear

    'until now the Word app has been a background process
    wdApp.Visible = True
    'we could use the Word app object to finish off
    'you may also want to things like generate a filename and save the file
    wdApp.Activate


End Sub

---

只需确保列E中没有任何内容，因为它在执行期间将独占值放在那里。希望有帮助。

谢谢。这就是我们所需要的。