- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 1# 偉婕
關於word 的vba 我不熟在此獻醜了,如有缺失尚請指教 word內有一欄為相片尚需高手指引
附件的xls與word的資料不一致 請自行修正
- Sub Ex()
- Dim MyXls As Object, Rng As Object, First As String, ii%, i%, T%, C%
- Set MyXls = CreateObject("EXCEL.APPLICATION")
- First = "E2" '附檔991011.xls檔案資料中第一筆資料的位置
- With MyXls
- .Visible = True
- .WORKBOOKS.Open ("D:\TEST\991011.xls") '打開 xls資料檔
- Set Rng = .WORKBOOKS(1).SHEETS(1).Range(First).End(2)
- Set Rng = Rng.End(4)
- Set Rng = .WORKBOOKS(1).SHEETS(1).Range(First, Rng) '取得資料
- End With
- Documents.Open "d:\test\991011.doc" ' 打開指定的word
- If Rng.Rows.Count > 5 Then ' 複製表格
- For i = 6 To Rng.Rows.Count Step 5 'Word每一資料表格數=5
- Set myRange = ActiveDocument.Range(Start:=ActiveDocument.Range.End - 1, End:=ActiveDocument.Range.End)
- With ActiveDocument.Tables(1)
- .Select
- Selection.Copy
- End With
- myRange.Select
- Selection.TypeParagraph
- Selection.TypeParagraph
- Selection.Paste
- Next
- End If
- C = 1: T = 1
- For i = 1 To Rng.Rows.Count '''''''''''''''複製xls資料 到 Word表格
- For ii = 1 To Rng.Columns.Count
- ActiveDocument.Tables(T).Cell(ii + IIf(ii <= 10, 1, 2), 1 + IIf(ii < 10, C, C + 1)).Range = Rng(i, ii)
- Next
- If i Mod 5 <> 0 Then
- C = C + 1
- Else
- T = Int(i / 5) + 1: C = 1
- End If
- Next '''''''''''''''複製xls資料 到 Word表格
- MyXls.Quit '關閉xls 檔案
- 'ActiveDocument.PrintOut '印列檔案
- 'ActiveDocument.SaveAs "d:\test\???doc" '存檔
- Application.Quit '關閉 Word
- End Sub
|
|
發表於 2010-10-12 20:10
| 
