access使用excel代码

时　间:2018-06-25 20:56:24
作　者:萤火虫   ID：66752  城市：大理
摘　要:非洲避暑
正　文:

在access环境中使用，需修改对象的前缀名，参照如下。

引用前期绑定
引用Microsoft Excel XX object Library
引用Microsoft ActiveX Date Objects 2.8
Private Sub cmd_启动_Click()
    Dim MyRecordset As New ADODB.Recordset
    Dim cnnDB As New ADODB.Connection
    Dim strSQL As String
    Dim xlApp As New Excel.Application
    Dim xlWbk As Excel.Workbook
    Dim xlsheet As Excel.Worksheet
    Dim c As Integer
    Dim b As Integer
    Set xlWbk = xlApp.workbooks.Add
    xlApp.Visible = True
    Set cnnDB = CurrentProject.Connection
    strSQL = "Select 付款日期, 承运商, 车牌号, 未付金额, 备注 FROM 表1"
    MyRecordset.Open strSQL, cnnDB
    Set xlsheet = xlWbk.Worksheets.Add
    xlsheet.Name = "原始信息"
    With xlsheet
    xlApp.Range("A2").CopyFromRecordset MyRecordset
    End With
    c = 1
    For b = 0 To MyRecordset.Fields.Count - 1
    xlApp.Activesheet.Cells(1, c).Value = MyRecordset.Fields(b).Name
    c = c + 1
    Next b
    Set xlsheet = xlWbk.Worksheets.Add
    xlsheet.Name = "处理结果"
  xlApp.Application.ScreenUpdating = False
  xlWbk.Sheets("处理结果").Activate
  Dim d, arr, key, i, j, k, m, n
  Set d = CreateObject("Scripting.Dictionary")
  arr = xlWbk.Sheets("原始信息").[A1].CurrentRegion.Value
  m = UBound(arr): n = UBound(arr, 2)
  For i = 2 To m
    d(arr(i, 2)) = d(arr(i, 2)) + arr(i, 4)
  Next
  ReDim brr(1 To m + d.Count, 1 To n)
  For Each key In d.keys
    For i = 2 To m
      If arr(i, 2) = key Then
        k = k + 1
        For j = 1 To n
          brr(k, j) = arr(i, j)
        Next
      End If
    Next
    k = k + 1
    brr(k, 2) = "小计": brr(k, 4) = d(key)
  Next
  k = k + 1
  brr(k, 2) = "合计": brr(k, 4) = xlApp.Application.Sum(d.items)
  With Range("A1")
    .CurrentRegion.Borders.LineStyle = 0
    .CurrentRegion.ClearContents
    .Resize(1, n) = xlApp.Application.Index(arr, 1, 0)
    .Offset(1).Resize(k, n) = brr
    .CurrentRegion.Borders.LineStyle = 1
  End With
  Range("A1:E100").Columns.AutoFit
  Range("A" & Rows.Count).End(xlUp).Offset(3, 0) = "时间：" & Format(Now(), "YYYY-MM-DD") & "        " & "制表人：***" & "        " & "审核人：***"
  xlApp.Application.DisplayAlerts = False
  xlWbk.Sheets("原始信息").Delete
  xlWbk.Sheets("sheet1").Delete
  xlWbk.Sheets("sheet2").Delete
  xlWbk.Sheets("sheet3").Delete
  xlApp.Application.ScreenUpdating = True
    ChDir "C:\Users\Administrator\Desktop"
    xlApp.ActiveWorkbook.SaveAs FileName:="C:\Users\Administrator\Desktop\报表.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    xlApp.Rows("1:1").Select
    xlApp.Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    xlApp.Rows("1:1").Select
    xlApp.Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    xlApp.Range("A1:E1").Select
    With xlApp.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    xlApp.Selection.Merge
    xlApp.Range("A1:E1").Select
    xlApp.ActiveCell.FormulaR1C1 = "供应商报表"
    xlApp.Range("A1:E1").Select
    With xlApp.Selection.Font
        .Name = "宋体"
        .Size = 16
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    xlApp.Selection.Font.Bold = True
    xlApp.Range("A2").Select
    xlApp.ActiveCell.FormulaR1C1 = "从" & Format(Now() - 30, "YYYY-MM-DD") & "到" & Format(Now(), "YYYY-MM-DD")
    xlApp.Range("A4:A100").Select
    xlApp.Selection.NumberFormatLocal = "yyyy/m/d"
    Set MyRecordset = Nothing
    Set xl = Nothing
    Set xlwkbk = Nothing
    Set xlsheet = Nothing
End Sub