VB+SQL怎样实现Excel报表？

两种方法
1.直接往excel里一格格的写2.先用excel做好模版，vb往指定单元格写数据

1.查出记录集，VB控制写入excel
2.直接用sql语句导入已存在的excel

这个不难啊,给你一段function自己看
文章
.NET(RSS)
ASP.NET(RSS)
Exchange 开发(RSS)
SQL SERVER(RSS)
Visual Basic 6(RSS)
开发实践(RSS)
其它(RSS)
杂志发表文章(RSS)
收藏
相册
SQL Server 2005
软件截图
我的照片
.NET技术站点
codeproject.com
微软官方站点asp.net
微软官方站点Gotdotnet
微软官方站点windowsforms
我的个人链接
CSDN文档中心
将下文加入到一个模块中,屏幕中调用如下ExporToExcel("select * from table")则实现将其导出到EXCEL中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

    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 = NothingEnd Function

下面的代码主要是将数据导入到模板excel，然后在另存到别的表中
Private Sub cmdExcel_Click()
On Error GoTo ErrHandler
   Dim strsql As String
   Dim strsql_db As String
   Dim jhze As Double
   Dim fkze As Double
   Dim wczcje As Double
   Dim yfkje As Double
   Dim fkje As Double
   Dim ce As Double

   Set xlapp1 = CreateObject("excel.application")
   xlapp1.Workbooks.Open (App.Path & "\按单位查询模板.xls")
   xlapp1.Workbooks("按单位查询模板.xls").Activate
   xlapp1.Worksheets(1).Cells(1, 1) = Text1.Text & "年按单位统计的完成资产统计表"
   strsql = "select * from table"
   'executesql是个数据库查询函数
   Set rs = ExecuteSQL(strsql, msgtext)
   For i = 6 To rs.RecordCount + 5
       xlapp1.ActiveSheet.Rows(i).Insert
       xlapp1.Worksheets(1).Cells(i, 1) = i - 5
       xlapp1.Worksheets(1).Cells(i, 2) = rs.Fields("单位名称")
       xlapp1.Worksheets(1).Cells(i, 3) = rs.Fields("计划总额")
       xlapp1.Worksheets(1).Cells(i, 4) = rs.Fields("付款总额")
       xlapp1.Worksheets(1).Cells(i, 5) = rs.Fields("完成资产金额")
       xlapp1.Worksheets(1).Cells(i, 6) = rs.Fields("预付款金额")
       xlapp1.Worksheets(1).Cells(i, 7) = rs.Fields("付款金额")
       xlapp1.Worksheets(1).Cells(i, 8) = rs.Fields("差额")
       rs.MoveNext
   Next i
   With CommonDialog1
         .DialogTitle = "生成Excel"
         .FileName = "*.xls"
         .Filter = "(Excel)*.xls|*.xls"
         .CancelError = True
         .ShowOpen
       '.ShowSave
   End With
      'xlapp1.Save
   xlapp1.ActiveWorkbook.SaveAs (CommonDialog1.FileName)

   xlapp1.Quit
   MsgBox "数据导Excel完成！", 48, "信息"
   rs.Close
   Set rs = Nothing
   Exit Sub
ErrHandler:
   '用户按了“取消”按钮
   MsgBox "用户取消从Excel导出数据操作！", 48, "提示"
   Exit Sub
End Sub

Dim msgtext As String
Dim mrc As ADODB.RecordsetPublic Function ExecuteSQL(ByVal sql As String, MsgString As String) As ADODB.Recordset
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim sTokens() As String
    'Dim SQL As String
    On Error GoTo ExecuteSQL_Error
    sTokens = Split(sql)
    Set cnn = New ADODB.Connection
    cnn.Open ConnectString
    If InStr("INSERT,DELETE,UPDATE", UCase$(sTokens(0))) Then
       cnn.Execute sql
       MsgString = sTokens(0) & "query successful"
    Else
       Set rst = New ADODB.Recordset
       rst.Open Trim$(sql), cnn, adOpenKeyset, adLockOptimistic


       Set ExecuteSQL = rst

       MsgString = "查询到" & rst.RecordCount & "条纪录"
    End If
ExecuteSQL_Exit:
    Set rst = Nothing
    Exit Function
    Set cnn = Nothing
ExecuteSQL_Error:
    MsgString = "查询错误:" & Err.Description
    Resume ExecuteSQL_Exit
End FunctionPublic Function ConnectString() As String
    ConnectString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\计划管理系统.mdb;Persist Security Info=False"
End Function

谢谢你们了！~我采用了 daisy8675(莫依 MS MVP-VB) ( ) 信誉：136 的函数
也谢谢 cuilei197979(风) 还有其他兄弟

调试易

VB+SQL怎样实现Excel报表？

解决方案 »