|
|
楼主 |
发表于 2009-3-31 21:50
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
守柔版主!!!!!!
守柔版主，这段程序在word VBA中无法运行啊 , 提示用户定义类型未定义,不知道automation怎么引用，请指教,谢谢!!!!!!
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 |
|
楼主: zhuomingkun
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-3-28 14:26
