每個獨特單元格的一個單詞文檔

Question

我有如下excel表格：

column A | B列|列C

X BOB APPLE

X BOB香蕉

X BOB PEAR

ýSARAH APPLE

ýSARAH KIWI

ŽCARL香蕉

žCARL PINEAPPLE

ŽCARL西瓜

ŽCARL KIWI

我想能夠循環通過塔A中，對於每個唯一的列中的值，產生一個word文檔與作爲名稱在列B的值的文件和列C作爲內容。在上表中，標題爲'Bob'的文件將包含'Apple Banana Pear'，另一個標題爲'Sarah'的文件將包含'Apple Kiwi'，第三個標題爲'Carl'的文件將包括'Banana Pineapple Watermelon Kiwi'。

我發現了一些代碼，我已經對我的情況做了調整，將我的Excel中的所有內容複製並粘貼到word文檔中，但這是我卡住的地方。不同的excel文檔有不同數量的行，有一次它是A列中的X，Y，Z，另一次是V，W，X，Y，Z.我知道我需要從x = 1循環到Len Cells（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 

Answer 1

我相信這應該做你想要什麼：

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，因爲它在執行過程中會將專屬值出現。希望能幫助到你。