如题!
导出到新建EXCLE没问题,就是想导到已经编辑过的EXCLE中,好做数据源用。
------解决方案--------------------
Set xlApp = CreateObject("Excel.application")
xlApp.Workbooks.Open( strFilePath )
'后面的操作和新建EXCLE的导出是一样的了
'strFilePath 就是你的那个已经存在的EXCLE文件路径及文件名
------解决方案--------------------
Sub Click(Source As Button)
On Error Goto p
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim s As New NotesSession
Dim db As NotesDatabase
Dim ajDC As NotesDocumentCollection
Dim ajDoc As NotesDocument
Dim larq As String '立案日期
Dim formula As String
Const path2Save = "E:\立案统计报表" '存储路径
Dim ygBuff As String '原告信息
Dim bgBuff As String '被告信息
Dim mcArray As Variant
Dim dwArray As Variant '地位
Dim dhArray As Variant '电话
Dim rowBegin As Integer
Dim ii As Integer
Dim xlsApp As Variant 'Excel对象
Set xlsApp = CreateObject("Excel.application")
If Not(xlsApp Is Nothing) Then
'在这个 Excel 文件当中添加一个 Sheet
xlsApp.Workbooks.Add
xlsApp.Visible = True
ii = 1
rowBegin = 1
xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 1).Value = "序号"
xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 2).Value = "案号"
xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 3).Value = "案件类型"
xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 4).Value = "原告信息"
xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 5).Value = "被告信息"
REM 导出数据至Excel
Set uidoc = ws.CurrentDocument
larq = Format(uidoc.FieldGetText("LARQ"),"yyyy年mm月dd日")
Set db = s.CurrentDatabase
formula = "(Form = 'Mostly')& (LARQ='"+larq+"')"
Set ajDC = db.Search(formula,Nothing,0)
Set ajDoc = ajDC.GetFirstDocument
While Not(ajDoc Is Nothing)
ygBuff = ""
bgBuff = ""
mcArray = Split(ajDoc.MC(0),"|")
dhArray = Split(ajDoc.LXDH(0),"|")
If(ajDoc.HasItem("DW"))Then
dwArray = Split(ajDoc.DW(0),"|")
For index = 0 To Ubound(dwArray)
If("原告" = dwArray(index) Or "申请人" = dwArray(index))Then
ygBuff = ygBuff + mcArray(index) + "##" + Trim(dhArray(index)) + ";"
Else
If("被告" = dwArray(index) Or "被申请人" = dwArray(index))Then
bgBuff = bgBuff + mcArray(index) + "##" + Trim(dhArray(index)) + ";"
End If
End If
Next
Else
For index = 0 To Ubound(mcArray)
bgBuff = bgBuff + mcArray(index) + "##" + Trim(dhArray(index)) + ";"
Next
End If
rowBegin = ii + 1
xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 1).Value = Cstr(ii)
xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 2).Value = ajDoc.AH(0)
xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 3).Value = ajDoc.ajlx(0)
xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 4).Value = ygBuff
xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 5).Value = bgBuff
Set ajDoc = ajDC.GetNextDocument(ajDoc)
ii = ii + 1
Wend
xlsApp.Workbooks(1).Worksheets(1).Columns("A:E").EntireColumn.AutoFit
If(Dir(path2Save,16) = "")Then '检查目录是否已经存在
Mkdir(path2Save)
End If
xlsApp.ActiveWorkbook.SaveAs( path2Save+"\"+larq+".xls")
'关闭资源
xlsApp.Quit
'资源释放
Set xlsApp = Nothing
'Msgbox("报表已经生成!")
'打开报表
ws.URLOpen(path2Save+"\"+larq+".xls")