7,763
社区成员
发帖
与我相关
我的任务
分享
Private Sub Command1_Click()
On Error GoTo finish
Dim xlApp As New Excel.Application '定义EXCEL类
Dim xlBook As New Excel.Workbook '定义工件簿类
Dim xlsheet As New Excel.Worksheet '定义工作表类
If Right(App.Path, 1) = "\" Then ' 若 App.Path 为根目录
fullpath = App.Path + "a.xls"
Else
fullpath = App.Path + "\" + "a.xls"
End If
'打开EXCEL
Set xlApp = CreateObject("Excel.Application", "") '创建EXCEL应用类
xlApp.Visible = False '设置EXCEL可见
Set xlBook = xlApp.Workbooks.Open(fullpath) '打开EXCEL工作簿
Set xlsheet1 = xlBook.Worksheets(1) '打开EXCEL工作表1
xlsheet1.Activate '激活工作表(
For i = 1 To Grid1.Rows - 1
xlsheet1.Cells(i + 4, 17) = Grid1.Cell(i, 6).Text '
ssql = "select * from a"
Set fj1 = cnn.Execute(ssql)
If Not fj1.EOF Then
xlsheet1.Cells(i + 4, 1) = fj1.Fields("f1")
End If
Next i
xlsheet1.Range("A" & i + 4 & ":X" & i + 4).Select
xlApp.Selection.HorizontalAlignment = xlLeft
xlApp.Selection.VerticalAlignment = xlCenter
xlApp.Selection.WrapText = True
xlApp.Selection.Orientation = 0
xlApp.Selection.AddIndent = False
xlApp.Selection.IndentLevel = 0
xlApp.Selection.ShrinkToFit = False
xlApp.Selection.ReadingOrder = xlContext
xlApp.Selection.MergeCells = False
xlApp.Selection.RowHeight = 30
'***************
xlApp.Selection.Merge
'运行第二遍时停在这个地方
'报错信息为“实时错误462:远程服务器不存在或不能使用”
'********************
xlsheet1.Cells(i + 4, 1) = " 合并表格 "
With CommonDialog1
.DialogTitle = "生成Excel"
.FileName = "*.xls"
.Filter = "(Excel)*.xls|*.xls"
.CancelError = True
.ShowSave
End With
xlBook.SaveAs (CommonDialog1.FileName)
SaveChanges = True
xlBook.Close
Set xlsheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
Application.Quit
Shell "taskkill /im EXCEL.exe /f", vbHide '强行杀死EXCEL.EXE进程
MsgBox "数据导Excel完成!", 48, "信息"
Exit Sub
finish:
If Err.Number = 429 Then
MsgBox "请先安装EXCEL!", , "导出错误"
Exit Sub
End If
xlApp.DisplayAlerts = False '关闭时不提示保存
xlApp.Quit '关闭EXCEL
xlApp.DisplayAlerts = True '关闭时提示保存
Set xlApp = Nothing
MsgBox " 导出数据到 Excel 时出错! ", , "导出错误"
End Sub