如何从数据库中统计的数据导入excell表中

Question

Public Sub RSwtoExcel(Cn As ADODB.Connection, strSQL As String, strFileName As String)
On Error GoTo err
    Dim Irow, Icol As Integer
    Dim Irowcount, Icolcount As Integer
    Dim Fieldlen() '存字段长度值
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim Data1 As New ADODB.Recordset    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    
    Data1.Open strSQL, Cn, adOpenStatic, adLockReadOnly
    With Data1
        .MoveLast
        
        If .RecordCount < 1 Then MsgBox "Error 没有记录!", vbCritical: Exit Sub
    
        Irowcount = .RecordCount '记录总数
        Icolcount = .Fields.Count '字段总数
    
        ReDim Fieldlen(Icolcount)
        .MoveFirst
    
        For Irow = 1 To Irowcount + 1
            For Icol = 1 To Icolcount
                Select Case Irow
                    Case 1 '在Excel中的第一行加标题
                        xlSheet.Cells(Irow, Icol).Value = Trim(.Fields(Icol - 1).Name)
                    Case 2 '将数组FIELDLEN()存为第一条记录的字段长
                
                        If IsNull(.Fields(Icol - 1)) = True Then
                            Fieldlen(Icol) = LenB(Trim(.Fields(Icol - 1).Name))    '如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
                        Else
                            Fieldlen(Icol) = LenB(Trim(.Fields(Icol - 1)))
                        End If
                    
                        xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)   'Excel列宽等于字段长
                        xlSheet.Cells(Irow, Icol).Value = Trim(.Fields(Icol - 1))  '向Excel的CellS中写入字段值
                    Case Else
                        Fieldlen1 = LenB(Trim(.Fields(Icol - 1)))
                    
                        If Fieldlen(Icol) < Fieldlen1 Then
                            xlSheet.Columns(Icol).ColumnWidth = Fieldlen1   '表格列宽等于较长字段长
                            Fieldlen(Icol) = Fieldlen1                      '数组Fieldlen(Icol)中存放最大字段长度值
                        Else
                            xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
                        End If
                    
                        xlSheet.Cells(Irow, Icol).Value = Trim(.Fields(Icol - 1))
                End Select
            Next
            If Irow <> 1 Then If Not .EOF Then .MoveNext
        Next
        
        With xlSheet
            .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"              '设标题为黑体字
            .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True              '标题字体加粗
            .Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous     '设表格边框样式
        End With
        xlApp.Visible = True '显示表格
        xlBook.SaveAs strFileName
        Set xlApp = Nothing '交还控制给Excel
        .Close
    End With
Exit Sub
err:
    If err.Number = 1004 Then MsgBox "不能访问“" & strFileName & "”文件。", vbCritical, "错误"
End Sub

Answer 1

HOWTO: Transfer Data from ADO Data Source to Excel with ADO 
http://support.microsoft.com/default.aspx?scid=kb;en-us;Q295646HOWTO: Transfer Data from ADO Recordset to Excel with Automation 
http://support.microsoft.com/default.aspx?scid=kb;en-us;Q246335

Answer 2

'指定链接
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long'Option Explicit
Dim x(1 To 4, 1 To 5) As Integer
Dim a, i, j As Integer
Dim b As StringPrivate Sub Command1_Click()
    Dim ex As Object
    Dim exbook As Object
    Dim exsheet As Object
    Set ex = CreateObject("Excel.Application")
    Set exbook = ex.Workbooks().Add
    Set exsheet = exbook.Worksheets("sheet1")
'按控件的内容赋值
'11
    exsheet.Cells(1, 1).Value = Text1.Text
'为同行的几个格赋值
    Range("C3").Select
    ActiveCell.FormulaR1C1 = "表格"
'    ex.Range("c3").Value = "表 格"
    ex.Range("d3").Value = " 春 天 "
    ex.Range("e3").Value = " 夏 天 "
    ex.Range("f3").Value = " 秋 天 "
    ex.Range("g3").Value = " 冬 天 "
'大片赋值
    ex.Range("c4:g7").Value = x
'按变量赋值
  a = 8
  b = "c" & Trim(Str(a))
  ex.Range(b).Value = "下雪"
'另外一种大片赋值
    For i = 9 To 12
    For j = 4 To 7
    exsheet.Cells(i, j).Value = i * j
    Next j
    Next i
'计算赋值
exsheet.Cells(13, 1).Formula = "=R9C4 + R9C5"
'设置字体
Dim exRange As Object
Set exRange = exsheet.Cells(13, 1)
exRange.Font.Bold = True'设置一行为18号字体加黑
 Rows("3:3").Select
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "宋体"
        .Size = 18
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
'设置斜体
    Range("E2").Select
    Selection.Font.Italic = True
'设置下划线
    Range("E3").Select
    Selection.Font.Underline = xlUnderlineStyleSingle'设置列宽为15
    Selection.ColumnWidth = 15'设置一片数据居中
Range("C4:G7").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
'设置某区域的小数位数
    Range("F4:F7").Select
    Selection.NumberFormatLocal = "0.00"
    
'求和
    Range("G9:G13").Select
    Range("G13").Activate
    ActiveCell.FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
'某列自动缩放宽度
    Columns("C:C").EntireColumn.AutoFit
'画表格
    Range("C4:G7").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
'加黑框
Range("C9:G13").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'设置某单元格格式为文本
    Range("E11").Select
    Selection.NumberFormatLocal = "@"
'设置单元格格式为数值
    Range("F10").Select
    Selection.NumberFormatLocal = "0.000_);(0.000)"
'设置单元格格式为时间
    Range("F11").Select
    Selection.NumberFormatLocal = "h:mm AM/PM"'取消选择
Range("C10").Select
'设置横向打印，A4纸张
'    With ActiveSheet.PageSetup
'        .PrintTitleRows = ""
'        .PrintTitleColumns = ""
'    End With
'    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
'        .LeftHeader = ""
'        .CenterHeader = ""
'        .RightHeader = ""
'        .LeftFooter = ""
'        .CenterFooter = ""
'        .RightFooter = ""
'        .LeftMargin = Application.InchesToPoints(0.75)
'        .RightMargin = Application.InchesToPoints(0.75)
'        .TopMargin = Application.InchesToPoints(1)
'        .BottomMargin = Application.InchesToPoints(1)
'        .HeaderMargin = Application.InchesToPoints(0.5)
'        .FooterMargin = Application.InchesToPoints(0.5)
'        .PrintHeadings = False
'        .PrintGridlines = False
'        .PrintComments = xlPrintNoComments
'        .PrintQuality = 300
'        .CenterHorizontally = False
'        .CenterVertically = False
        .Orientation = xlLandscape
'        .Draft = False
        .PaperSize = xlPaperA4
'        .FirstPageNumber = xlAutomatic
'        .Order = xlDownThenOver
'        .BlackAndWhite = False
'        .Zoom = 100
    End With
'跨列居中
    Range("A1:G1").Select
    With Selection
        .HorizontalAlignment = xlCenter
'        .VerticalAlignment = xlBottom
'        .WrapText = False
'        .Orientation = 0
'        .AddIndent = False
'        .ShrinkToFit = False
        .MergeCells = True
    End With
    Selection.Merge'打印表格
ActiveWindow.SelectedSheets.PrintOut Copies:=1'取值
Text1.Text = exsheet.Cells(13, 1)
'保存
ChDir "C:\WINDOWS\Desktop"
ActiveWorkbook.SaveAs FileName:="C:\WINDOWS\Desktop\aaa.xls", FileFormat:=xlNormal, Password:="123", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
   ' 关闭工作表。
   exbook.Close
   '用 Quit 方法关闭 Microsoft Excel
   ex.Quit
   '释放对象
   Set ex = Nothing
   Set exbook = Nothing
   Set exsheet = Nothing
Dim retval
'用excel打开表格
retval = Shell("C:\Program Files\Microsoft Office\Office\EXCEL.EXE" & " " & "C:\WINDOWS\Desktop\aaa.xls", 1)
   End SubPrivate Sub Form_Load()
    Me.Show
End SubPrivate Sub Image2_Click()
'打开主页
ret& = ShellExecute(Me.hwnd, "Open", "http://dyqing.533.net", "", App.Path, 1)End SubPrivate Sub Image1_Click()
'发送邮件
ret& = ShellExecute(Me.hwnd, "Open", "mailto:[email protected]", "", App.Path, 1)End Sub