急求（高分），如何将VB查询SQL数据库的结果导出Excel表

Question

用bcp实现除外

Answer 1

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 = cn
        .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
    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing
End Function

Answer 2

Dim rs As New ADODB.Recordset
    Dim cn As New ADODB.Connection
    Dim strsql As String    
strsql = "select * from aaa"
    cn.Open sCon_Stock
    rs.Open strsql, cn, adOpenStatic
    
    If rs.EOF = False Then
        '另存到XLS文件
        Dim omyXLS As New Excel.Application
        omyXLS.Visible = False
        omyXLS.DisplayAlerts = False
        omyXLS.ScreenUpdating = False
        omyXLS.Workbooks.Add
        omyXLS.Range("a2").CopyFromRecordset rs
        sFileName = App.Path & "\rs\库存查询结果" & Format(Now, "YYYYMMDDHHMMSS") & ".XLS"
        omyXLS.ActiveWorkbook.SaveAs FileName:=sFileName, FileFormat:=xlNormal, _
        PassWord:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
        
        omyXLS.Visible = True
        omyXLS.ScreenUpdating = True
        omyXLS.DisplayAlerts = True
        omyXLS.Application.Quit
        Set omyXLS = Nothing
        MsgBox "文件已生成,在:" & sFileName
    End If
    Set rs = Nothing
    Set cn = Nothing

Answer 3

On Error GoTo handle
    Dim Excel As Application
    Dim Excelbook As Workbook
    Dim Excelsheet As Worksheet
    Dim X() As String
    Dim SaveRoad As String
    Dim Cst As New ADODB.Connection
    Dim Rst As New ADODB.Recordset
    Dim Datanum As Long, Datanum1 As Long  
    Dim Flag As Integer
    Dim J As Integer
    Dim I As Integer    Set Excel = CreateObject("Excel.application")
    Set Excelbook = Excel.Workbooks().Add
    Set Excelsheet = Excelbook.Worksheets("sheet1")
    
    ReDim X(Adodc1.Recordset.RecordCount, Adodc1.Recordset.Fields.Count)
    Adodc1.Recordset.MoveFirst
    For I = 0 To Adodc1.Recordset.RecordCount - 1
        For J = 0 To Adodc1.Recordset.Fields.Count - 1
          X(I, J) = Trim(Adodc1.Recordset.Fields.Item(J))
        Next J
      Adodc1.Recordset.MoveNext
    Next I
    
      Excel.Range("a1:j" & Trim(Adodc1.Recordset.RecordCount) & "").Value = X
      Excelsheet.Application.Visible = False
      Excelsheet.SaveAs SaveRoad
      Excelsheet.Application.Quit
      Set Excelsheet = Nothing
      MsgBox "", 48 + vbOKOnly, ""
     Exit Sub
    
handle:
  Exit Sub
End Sub

Answer 4

一个连接MSSQL的模块
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public conn As New ADODB.Connection
Public rs As New ADODB.Recordset
Public addFlag As Boolean
Public strSql As String
 
Public Function OpenCn() As Boolean
Dim mag As String
On Error GoTo strerrmag
Set conn = New ADODB.Connection
conn.ConnectionTimeout = 30
conn.CommandTimeout = 120
conn.CursorLocation = adUseClient
conn.ConnectionString = "Provider=SQLOLEDB;Persist Security Info=False;User ID=用户名;PWD=密码;Initial Catalog=数据库名;Data Source=服务器名"conn.Open , , , adAsyncConnectDo While conn.State <> adStateOpen And conn.State <> adStateClosed
    Sleep 50
    DoEvents
LoopOpenCn = True
Exit Function
strerrmag:
mag = "Data can't connect"
Call MsgBox(mag, vbOKOnly, "Error:Data connect")
OpenCn = False
Exit Function
End FunctionPublic Sub clocn()
On Error Resume Next
If conn.State <> adStateClosed Then conn.Close
Set conn = Nothing
End Sub
Public Function openrs(ByVal strSql As String) As Boolean   
Dim mag As String
Dim rpy As Boolean
On Error GoTo strerrmag
Set rs = New ADODB.Recordset
'If addFlag = False Then rpy = True
With rs
.ActiveConnection = conn
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open strSql, , , , adAsyncExecute
Do While rs.State <> adStateClosed And rs.State <> adStateOpen
    Sleep 50
    DoEvents
Loop
End With
'addFlag = True
openrs = True
Exit Function
strerrmag:
mag = "data not connect"
Call MsgBox(mag, vbOKOnly, "error:connect")
openrs = False
End Function
Public Sub clors()
On Error Resume Next
If rs.State <> adStateClosed Then rs.Clone
Set rs = Nothing
End Sub

Answer 5

public StrSQL string
strSQL=strSQL+"Select *   "+vbcr                 '不一定是全部列，不分列需要指明列名
--------------------------------------------当两个库在一个服务器时
strSQL=strSQL+"From 数据源库名.dbo.表名"+vbcr
call OpenCn()
if openrs(strSQL)=true then
      Sheets("sheet名").Range("A1").CopyFromRecordset rs '起始单元格
endif
call clors()
call clocn()

Answer 6

楼上各位的都没有注释和说明，让人看的云里雾里,本人献丑了
我的如下：
    假设rs1(recordset)为你要导出的数据,你点击Command1按钮就能导出数据,代码如下:    Private Sub Command1_Click()
    On Error GoTo Hand
        Dim xlApp As New Excel.Application
        Dim xlWorkbook As Excel.Workbook
        Dim xlSheet As Excel.Worksheet
        Dim xlQuery As Excel.QueryTable
        xlApp.Visible = True
        Set xlWorkbook = xlApp.Workbooks.Add
        Set xlSheet = xlWorkbook.Worksheets(1)
        Set xlQuery = xlSheet.QueryTables.Add(rs1, xlSheet.Range("A1"))
        xlQuery.FieldNames = True
        xlQuery.Refresh
        Exit Sub
    Hand:
        MsgBox Err.Description, vbCritical, "导入失败"
    End Sub    必须注意两点:
    1.机器必须安装OFFICE
    2.rs1在open前必须要有rs1.CursorLocation = adUseClient语句