[發問] 如何使用VBA將EXCLE列出的清單轉成WORD

et010884

各位大大:
請問一下VBA有功能將附件的Excle記錄內的資料 轉成word嗎?
且另外在清單的頁面在紀錄轉成word的資料
轉換後記錄頁面的資料清空

GBKEE

回復 6# et010884

1. Option Explicit
   
2. Dim Word檔 As String   '匯出word檔,存檔的名稱
   
3. Dim 紀錄 As Range
   
4. Sub 匯出word() '由清單複製後匯出word檔
   
5.     Set 紀錄 = Sheets("紀錄").[c2:m2]
   
6.    MsgBox Application.CountA(紀錄)
   
7.     If Application.CountA(紀錄) <> 11 Then
   
8.         MsgBox "資料不齊全": Exit Sub
   
9.     Else
   
10.          Do
    
11.          Word檔 = Application.InputBox("*.doc", "匯出word檔,存檔的名稱")
    
12.          Loop While Word檔 = "False" Or Word檔 = ""
    
13.          If Not InStr(LCase(Word檔), "*.doc") Then Word檔 = Word檔 & ".doc"
    
14.     End If
    
15.     Main
    
16.     清單檢查
    
17. End Sub
    
18. Sub 清單檢查()   '檢查紀錄不存在: 詢問是否加入
    
19.     Dim R As Integer, E As Range, MM As String
    
20.     Set 紀錄 = Sheets("紀錄").[c2:m2]
    
21.     With Sheets("清單")
    
22.         R = .Cells(.Rows.Count, "c").End(xlUp).Row   '清單:紀錄的列數
    
23.         If R = 1 Then
    
24.             GoTo OK
    
25.         Else
    
26.             MM = Join(Application.Transpose(Application.Transpose(紀錄.Value)), vbLf)
    
27.             For Each E In .Range("C2:M2").Resize(R - 1).Rows
    
28.                 If MM = Join(Application.Transpose(Application.Transpose(E.Value)), vbLf) Then GoTo EE
    
29.             Next
    
30.         End If
    
31. OK:
    
32.         If MsgBox(MM, vbYesNo, "記錄: 存入清單..") = vbYes Then
    
33.             紀錄.Copy .Cells(R + 1, "c")                 '複製到紀錄的列數+1
    
34.             .Cells(R + 1, "B").NumberFormatLocal = "@"
    
35.             .Cells(R + 1, "B").FormulaR1C1 = Format(R + 1, "000")
    
36.         End If
    
37. EE:
    
38.         紀錄.EntireRow = ""          '轉換後記錄頁面的資料清空
    
39.     End With
    
40. End Sub
    
41. Sub 複製到紀錄()
    
42.     Dim Rng As Range
    
43.     With Sheets("清單")
    
44.           Set Rng = .Range("a1").CurrentRegion.Rows(2)
    
45.           Set Rng = Rng.Resize(.Range("a1").CurrentRegion.Rows.Count - 1)
    
46.             If Not Application.Intersect(Rng, ActiveCell) Is Nothing Then
    
47.                 .Range("A" & ActiveCell.Row & ":" & "M" & ActiveCell.Row).Copy Sheets("紀錄").Range("A2")
    
48.                 MsgBox "編號: " & vbTab & "[" & .Range("B" & ActiveCell.Row) & "]", , "複製到紀錄!!"
    
49.             Else
    
50.                 MsgBox "需選擇在 清單的範圍"
    
51.                 Rng.Select
    
52.             End If
    
53.         End With
    
54. End Sub
    
55. Private Sub Main()                 '記錄匯出到word檔
    
56.     With CreateObject("Word.APPLICATION")
    
57.         .Visible = True
    
58.        ' .Documents.Open ("\\Tctk0fi25\oqa_report$\04_異常處理表單_R3\不合格單開立區\1.doc")
    
59.        .Documents.Open (ThisWorkbook.Path & "\1.doc")
    
60.         With .ActiveDocument.Tables(1)  'Word檔案中第一個表格
    
61.         ' .Cell(2, 1) = Rng(1, 1) '項次
    
62.          '.Cell(2, 2) = Rng(1, 2) '編號
    
63.          .Cell(2, 2) = 紀錄(1, 1) '發行日期
    
64.          .Cell(2, 3) = 紀錄(1, 2) 'Product code
    
65.          .Cell(2, 4) = 紀錄(1, 3) '客戶
    
66.          .Cell(2, 5) = 紀錄(1, 4) 'Product code
    
67.          .Cell(2, 6) = 紀錄(1, 5) 'Lot id
    
68.          .Cell(2, 7) = 紀錄(1, 6) 'line
    
69.         .Cell(2, 8) = 紀錄(1, 7) 'Qty
    
70.          .Cell(4, 2) = 紀錄(1, 8) '內容
    
71.          .Cell(5, 3) = 紀錄(1, 9) '收件日期
    
72.          .Cell(5, 7) = 紀錄(1, 10) '核對人
    
73.           .Cell(9, 4) = 紀錄(1, 11) 'Detail Explain
    
74.          '.Cell(?, ?)= 職稱 ,年資 , 紀錄, 面談者:餘下資料請自行填入
    
75.         End With
    
76.            .ActiveDocument.SaveAs Filename:="D:\TEST\" & Word檔 '*** WORD匯出 ***
    
77.            .ActiveDocument.Close                                    '關閉word檔 'True
    
78.         .Quit                                                       '關閉word應用程式
    
79.     End With   
    
80. End Sub

複製代碼

et010884

回復 5# GBKEE


    GBKEE大大
已補上說明
清單的分頁為歷史紀錄,如要匯出歷史紀錄只需要區選範圍後按複製即可轉到紀錄頁面
另外如要由紀錄分頁新增清單時則由分頁的另一個按鈕執行新增的動作

最後謝謝你 大力的協助

GBKEE

回復 4# et010884
工作表 的 [項次] WORD的.DOC  沒見到 :請說明後再做 紀錄,清單的程序
如要重發: 已發出之紀錄:請在[清單]工作表先做一些紀錄範例

1. Option Explicit
   
2. Sub 結束匯出()
   
3.     Dim RNG As Range, ss As Object
   
4.     Set RNG = Sheets("紀錄").[A2]
   
5.     With CreateObject("Word.APPLICATION")
   
6.         .Visible = True
   
7.         .Documents.Open (ThisWorkbook.Path & "\1.doc")
   
8.         Set ss = .ActiveDocument.Sentences(1)
   
9.         
   
10.         '*** Word VBA:  Sentences 集合物件 請參閱屬性方法事件特定多重物件
    
11.         '這是由 Range 物件所組成的集合，代表選取範圍、範圍或文件中的所有句子。沒有所謂 Sentence 物件。
    
12. 
    
13.         .ActiveDocument.Range(InStr(ss, "："), Len(ss) - 1) = RNG(1, 2)
    
14.         '文件編號
    
15.         With .ActiveDocument.Tables(1)  'Word檔案中第一個表格
    
16.         ' .Cell(2, 1) = Rng(1, 1) '項次  '*** 清單的哪一項***
    
17.          .Cell(2, 2) = RNG(1, 3) '發行日期
    
18.          .Cell(2, 3) = RNG(1, 4) 'Product code
    
19.          .Cell(2, 4) = RNG(1, 5) '客戶
    
20.          .Cell(2, 5) = RNG(1, 6) 'Product code
    
21.          .Cell(2, 6) = RNG(1, 7) 'Lot id
    
22.          .Cell(2, 7) = RNG(1, 8) 'line
    
23.         .Cell(2, 8) = RNG(1, 9) 'Qty
    
24.          .Cell(4, 2) = RNG(1, 10) '內容
    
25.          .Cell(5, 3) = RNG(1, 11) '收件日期
    
26.          .Cell(5, 7) = RNG(1, 12) '核對人
    
27.           .Cell(9, 4) = RNG(1, 13) 'Detail Explain
    
28.          '.Cell(?, ?)= 職稱 ,年資 , 紀錄, 面談者:餘下資料請自行填入
    
29.         End With
    
30.          .ActiveDocument.SaveAs Filename:="D:\OK.doc"  '*** WORD匯出 ***
    
31.          '.ActiveDocument.Close True
    
32.         .Quit
    
33.     End With
    
34.    
    
35.     'Rng.Resize(1, 13) = "" '轉換後記錄頁面的資料清空
    
36. End Sub

複製代碼

et010884

回復 2# GBKEE

GBKEE大大:
小弟還有幾個問題,請你幫忙解答
1.希望有另存新檔的功能=WORD匯出時
2.紀錄開單匯出分頁如完成匯出則紀錄在開單紀錄清單但重複開單的不紀錄
3.想在開單紀錄清單選擇已開過的清單再開立一次
4. Word檔 文件編號那一欄位城市要怎麼寫
請在幫幫忙
謝謝

et010884

回復 2# GBKEE


    GBKEE 大大: 謝謝你 在請問一下 我的格式如果是合併儲存格時 要如何換格

GBKEE

回復 1# et010884
試試看

1. Option Explicit
   
2. Sub 結束匯出()
   
3.     Dim Rng As Range
   
4.     Set Rng = Sheets("紀錄").[A2]
   
5.     With CreateObject("Word.APPLICATION")
   
6.         .Visible = True
   
7.         .Documents.Open ("完整的路徑檔案名稱.doc")
   
8.         With .ActiveDocument.Tables(1)  'Word檔案中第一個表格
   
9.          .Cell(1, 1) = Rng(1, 1) '姓名
   
10.          .Cell(1, 2) = Rng(1, 2) '編號
    
11.          .Cell(1, 3) = Rng(1, 3) '部門
    
12.          '.Cell(?, ?)= 職稱 ,年資 , 紀錄, 面談者:餘下資料請自行填入
    
13.         End With
    
14.         .ActiveDocument.Close True
    
15.         .Quit
    
16.     End With
    
17.     Rng.Resize(1, 7) = "" '轉換後記錄頁面的資料清空
    
18. End Sub

複製代碼