在VB6.0里可以把数据批量插入到Excel中吗？

[xuetianliang]

我在数据库中查询出一个结果集，可不可以直接把这个结果集插入到Excel中，

[guoyx]

当然可以!!就是VBA方式。

[NetShape]

当然可以,我以前是写个函数来实现的.你也可以试试.很简单的

[mathematician]

Public Conn As New ADODB.Connection '注意Conn对象声明必须放在模块中，且需声明为Public

'将下文加入到一个模块中,屏幕中调用如下ExporToExcel("select * from table")则实现将其导出到EXCEL中
'
'注: 须在程序中引用 'Microsoft Excel 9.0 Object Library'和ADO对象,机器必装Excel 2000
'
'本程序在Windows 98/2000,VB 6 下运行通过。


Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer

Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable

With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Conn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With

With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With

Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True

'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))

With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With

xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh

With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With

With xlSheet.PageSetup
.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" ' & Gsmc
.CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
.LeftFooter = "&""楷体_GB2312,常规""&10制表人："
.CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
.RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
End With

xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing

End Function


很久以前在csdn找到的一段代码，一直用着呢，现在分享一下吧！:)

[阿建像熊猫]

Public Sub saveExcelInput()
With dlgExcelSave
.FileName = ""
.CancelError = True
.DialogTitle = "±£´æ"
.Filter = "ExcelÊý¾ÝÎļþ|*.xls"
On Error GoTo aaa
.ShowSave
End With

If Dir(dlgExcelSave.FileName) <> "" Then

If MsgBox("¡°" & dlgExcelSave.FileName & "¡±ÎļþÒѾ­´æÔÚ£¬ÊÇ·ñ´ú»»£¿", 16 + vbYesNo, "ÌáÎÊ") = vbYes Then
Kill dlgExcelSave.FileName
Else
Exit Sub
End If

End If
Dim i As Integer
Dim exstring As String
Dim exConn As ADODB.Connection
Dim exRs As ADODB.Recordset
Dim exPath As String
Dim exName As String
Dim exPos As Integer

exPos = InStrRev(dlgExcelSave.FileName, "\")
exPath = Left(dlgExcelSave.FileName, exPos - 1)
exName = Right(dlgExcelSave.FileName, Len(dlgExcelSave.FileName) - exPos)


' exName = Left(dlgExcelSave.FileName ,)

Set exConn = New ADODB.Connection
Set exRs = New ADODB.Recordset

exConn.Open "Driver={Microsoft Excel Driver (*.xls)};UID=;PWD=;DBQ=" & exPath



For i = 0 To ListFieldPrint.ListCount - 1
exstring = exstring & ListFieldPrint.List(i) & " char(50) ,"
Next

exstring = Left(exstring, Len(exstring) - 1)
exConn.Execute "create table " & exName & "(" & exstring & ")"
exRs.Open "select * from " & exName, exConn, 2, 2

'''
Dim rs As ADODB.Recordset
Dim sql As String
Dim j As Integer
Set rs = New ADODB.Recordset
sql = "select * from " & sqlTable
conndbOpen
rs.Open sql, conn, 1, 1

If rs.RecordCount = 0 Then
MsgBox "ûÓÐÊý¾Ý£¬µ«Äܵ¼³öÊý¾Ý¿â½á¹¹£¡", 48, "Ìáʾ"
End If

ProgressExcel.Visible = True
ProgressExcel.Max = rs.RecordCount
If sqlTable = "Apparatus" Or sqlTable = "Consignment" Then '''µ±Ñ¡ÔñÁ˱íApparatus»òÕßConsignmentµÄʱºò
Do While Not rs.EOF
exRs.AddNew
For i = 0 To ListFieldPrint.ListCount - 1
If ListFieldPrint.List(i) = "Ê¡±àºÅ" Then '''»ñµÃÊ¡Ãû

Dim Prs As ADODB.Recordset
Dim Psql As String
Set Prs = New ADODB.Recordset
Psql = "select * from Province where Ê¡±àºÅ='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Prs.Open Psql, conn, 1, 1

If Not (Prs.BOF And Prs.EOF) Then
exRs.Fields(i).Value = Prs.Fields("Ê¡Ãû").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
ElseIf ListFieldPrint.List(i) = "ÊбàºÅ" Then '''»ñµÃ³ÇÊÐÃû

Dim Crs As ADODB.Recordset
Dim Csql As String
Set Crs = New ADODB.Recordset
Csql = "select * from City where ÊбàºÅ='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Crs.Open Csql, conn, 1, 1

If Not (Crs.BOF And Crs.EOF) Then
exRs.Fields(i).Value = Crs.Fields("ÊÐÃû").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If

ElseIf ListFieldPrint.List(i) = "µ¥Î»±àºÅ" Then '''»ñµÃµ¥Î»Ãû

Dim Srs As ADODB.Recordset
Dim Ssql As String
Set Srs = New ADODB.Recordset
Ssql = "select * from School where µ¥Î»´úÂë='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Srs.Open Ssql, conn, 1, 1

If Not (Srs.BOF And Srs.EOF) Then
exRs.Fields(i).Value = Srs.Fields("µ¥Î»").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If

Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If

Next
exRs.Update
j = j + 1
ProgressExcel.Value = j
rs.MoveNext
Loop
Else
Do While Not rs.EOF
exRs.AddNew
For i = 0 To ListFieldPrint.ListCount - 1
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
Next
exRs.Update
j = j + 1
ProgressExcel.Value = j
rs.MoveNext
Loop
End If
MsgBox "µ¼³öÍê³É£¡", 64, "Ìáʾ"
' ProgressExcel.Value = 0
'''
Prs.Close
Set Prs = Nothing
Crs.Close
Set Crs = Nothing
Srs.Close
Set Srs = Nothing
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
exRs.Close
Set exRs = Nothing
exConn.Close
Set exConn = Nothing
aaa:
' Exit Sub
End Sub

[lyz803]

我的例子和三楼的差不多，我就不写啦！我已经在我的程序内使用多次！

[fengziwei]

同意三楼的，我都已经试过了，可以！
同时在此表示感谢！！