|
|
原帖由 lhdcxz 于 2009-3-27 19:17 发表 
我也有类似的问题。请版主赐教如下代码：
1、在Excel工作簿“主表”里打开Excel工作簿“数据源”和Word文档“目标”，把Excel工作簿“数据源”里A列的内容复制到Excel工作簿“主表”的A列里；
2、并且按照Excel工作 ...
请参考：
Option Explicit
Sub Example()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim strDbFullName As String
Dim strWdFullName As String
Dim xlDB As Excel.Workbook
Dim strEndCell As String
Dim strBeginCell As String
Dim myArray() As String
Dim myRange As Range
Dim C As Range
Dim N As Long
Dim blnNotExists As Boolean
On Error Resume Next
strDbFullName = ThisWorkbook.Path & "\数据源.xls"
If Len(Dir(strDbFullName, vbDirectory)) = 0 Then
MsgBox "Excel未找到" & strDbFullName, vbExclamation
Exit Sub
End If
Set xlDB = GetObject(strDbFullName)
With xlDB.Worksheets("Sheet1")
strBeginCell = "$A$1"
strEndCell = .[A65536].End(xlUp).Address
Set myRange = .Range(strBeginCell, strEndCell)
End With
N = myRange.Cells.Count
ReDim myArray(N - 1)
N = 0
For Each C In myRange
myArray(N) = C.Value
N = N + 1
Next
xlDB.Close True
With ThisWorkbook.Worksheets("Sheet1")
Set myRange = .Range(strBeginCell, strEndCell)
myRange.Value = Excel.WorksheetFunction.Transpose(myArray)
End With
ThisWorkbook.Save
strWdFullName = ThisWorkbook.Path & "\目的.doc"
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set wdApp = CreateObject("Word.Application")
blnNotExists = True
End If
Set wdDoc = wdApp.Documents.Add
With wdDoc
'' wdDoc.Application.Visible = True '可用于调试
.Content.InsertAfter Join(myArray, Chr(13) & "123456" & Chr(13) & Chr(13))
.SaveAs Filename:=strWdFullName
.Close
Set wdDoc = Nothing
End With
If blnNotExists = True Then wdApp.Quit
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-3-26 17:57
楼主