VBA 把accesss数据库的工资表数据写入到excel 表里

rendiule01

搞了好几天，都没弄出来？请各路大神指点下，解惑？
  把access 数据库工资表数据写入到excel 表里,希望在access里实现
     写入前先清空excel 文件sheet 明细表，再写入
报错调试在黄色区域，
  运行错误424 要求对象   
' 将 Access 数据库表或查询的数据写入 Excel 文件中
    excelSheet.Range("A2").Resize(UBound(accessData, 2)+1, UBound(accessData, 1)+1).Value =excelApp. WorksheetFunction.Transpose(accessData)
Private Sub Aexcel()
  ' 创建对 Excel 应用程序的新引用
    Dim excelApp As Object
    Set excelApp = CreateObject("Excel.Application")
    ' 尝试获取任何现有的 Excel 应用程序引用
    On Error Resume Next
    Set excelApp = GetObject(, "Excel.Application")
    On Error GoTo 0
    ' 如果应用程序不存在，则返回新创建的引用
    If excelApp Is Nothing Then
        Set excelApp = CreateObject("Excel.Application")
    End If
    ' 打开 Excel 文件
    Dim excelWorkbook As Object
    Set excelWorkbook = excelApp.Workbooks.Open("D:\工资单\工资单模板.xlsm")
    ' 获取 Excel 文件的工作表对象
    Dim excelSheet As Object
    Set excelSheet = excelWorkbook.WorkSheets("明细表")
    ' 清空 sheet 数据
    excelSheet.Cells.ClearContents
    ' 获取 Access 数据库表或查询的数据
    Dim accessData As Variant
    accessData = CurrentDb.OpenRecordset("SELECT * FROM 工资明细表").GetRows() 'DAO不支持这种写法,ADO没问题
    ' 将 Access 数据库表或查询的数据写入 Excel 文件中
    excelSheet.Range("A2").Resize(UBound(accessData, 2)+1, UBound(accessData, 1)+1).Value= excelApp.WorksheetFunction.Transpose(accessData)   
    ' 保存并关闭 Excel 文件
    excelWorkbook.Save
    excelWorkbook.Close
    excelApp.Quit
    Set excelSheet = Nothing
    Set excelWorkbook = Nothing
    Set excelApp = Nothing  
End Sub

'''''下面是完整代码'''''''''''''''''''''''''''''''''''''''''

Private Sub Aexcel()
    ' 创建对 Excel 应用程序的新引用
    Dim excelApp As Object
    Set excelApp = CreateObject("Excel.Application")
    ' 尝试获取任何现有的 Excel 应用程序引用
    On Error Resume Next
    Set excelApp = GetObject(, "Excel.Application")
    On Error GoTo 0
   
    ' 如果应用程序不存在，则返回新创建的引用
    If excelApp Is Nothing Then
        Set excelApp = CreateObject("Excel.Application")
    End If
   
    ' 打开 Excel 文件
    Dim excelWorkbook As Object
    Set excelWorkbook = excelApp.Workbooks.Open("D:\工资单\工资单模板.xlsx")
   
    ' 获取 Excel 文件的工作表对象
    Dim excelSheet As Object
    Set excelSheet = excelWorkbook.WorkSheets("明细表")
   
    ' 清空 sheet 数据
    excelSheet.Cells.ClearContents
   
    ' 获取字段名
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("SELECT * FROM 工资明细表")
    Dim excelHeader As Variant
    ReDim excelHeader(0 To rst.Fields.count - 1)
    For i = 0 To rst.Fields.count - 1
        excelHeader(i) = rst.Fields(i).Name
    Next i
    rst.Close
    Set rst = Nothing
   
    ' 将字段名写入 Excel Sheet 的第一行
    For i = 0 To UBound(excelHeader)
        excelSheet.Cells(1, i + 1) = excelHeader(i)
    Next i
   
    ' 将 Access 数据库表或查询的数据写入 Excel 文件中
    excelSheet.Range("A2").CopyFromRecordset CurrentDb.OpenRecordset("SELECT * FROM 工资明细表")
   
    ' 保存并关闭 Excel 文件
    excelWorkbook.Save
    excelWorkbook.Close
    excelApp.Quit
    Set excelSheet = Nothing
    Set excelWorkbook = Nothing
    Set excelApp = Nothing
End Sub

Yalishanda30

为什么不在excel端操作，access当作数据库不行吗

f8b1987

rendiule01

f8b1987 发表于 2023-5-3 14:28

谢谢大佬的帮助，若是在excel 操作我会，现需要在access操作，access vba代码

f8b1987

rendiule01 发表于 2023-5-3 15:36
谢谢大佬的帮助，若是在excel 操作我会，现需要在access操作，access vba代码

那我看错了哈。其实原理一样的，只是多了调用excel

    ' 将 Access 数据库表或查询的数据写入 Excel 文件中
    excelSheet.Range("A2").Resize(UBound(accessData, 2) + 1, UBound(accessData, 1)) = excelApp.WorksheetFunction.Transpose(accessData)

f8b1987

rendiule01

f8b1987 发表于 2023-5-3 16:31
那我看错了哈。其实原理一样的，只是多了调用excel

    ' 将 Access 数据库表或查询的数据写入 Excel  ...

谢谢大神，按照你的方法，但是出来的数据只有一行，工资明细表实际7行，怎么修改？








Private Sub Aexcel()
  ' 创建对 Excel 应用程序的新引用
    Dim excelApp As Object
    Set excelApp = CreateObject("Excel.Application")
   
    ' 尝试获取任何现有的 Excel 应用程序引用
    On Error Resume Next
    Set excelApp = GetObject(, "Excel.Application")
    On Error GoTo 0
   
    ' 如果应用程序不存在，则返回新创建的引用
    If excelApp Is Nothing Then
        Set excelApp = CreateObject("Excel.Application")
    End If
   
    ' 打开 Excel 文件
    Dim excelWorkbook As Object
    Set excelWorkbook = excelApp.Workbooks.Open("D:\工资单\工资单模板.xlsx")
   
    ' 获取 Excel 文件的工作表对象
    Dim excelSheet As Object
    Set excelSheet = excelWorkbook.WorkSheets("明细表")
   
    ' 清空 sheet 数据
    excelSheet.Cells.ClearContents
   
    ' 获取 Access 数据库表或查询的数据
    Dim accessData As Variant
    accessData = CurrentDb.OpenRecordset("SELECT * FROM 工资明细表").GetRows()
   
    ' 将 Access 数据库表或查询的数据写入 Excel 文件中
    excelSheet.Range("A2").Resize(UBound(accessData, 2) + 1, UBound(accessData, 1)) = excelApp.WorksheetFunction.Transpose(accessData)

    ' 保存并关闭 Excel 文件
    excelWorkbook.Save
    excelWorkbook.Close
    excelApp.Quit
    Set excelSheet = Nothing
    Set excelWorkbook = Nothing
    Set excelApp = Nothing
   
End Sub

WANT-T

试试这样：
excelSheet.Range("A2").copyfromrecordset CurrentDb.OpenRecordset("SELECT * FROM 工资明细表")
在你报错的位置，将两句换成一句