Question

使用hta，我正在尝试从Access数据库中提取数据，并希望粘贴到新的Excel文件中。下面是我尝试过的代码，但是我不知道如何打开新的Excel文件以及如何将查询数据粘贴到该Excel文件中。

下面是我尝试过的代码。

Dim conn 'GLOBAL doing this here so that all functions can use it
sub dotheconnection
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source= C:\Users\Database\data.mdb;User Id=; Password="
    If conn.errors.count <> 0 Then 
        alert("problem connecting to the database")
    end if
end Sub


sub Search
   SQL_query = "SELECT * FROM dvd WHERE agent = 'Sharath Chandra Das' "
    Set rsData = conn.Execute(SQL_query)
    'Here i want a code which should open new excel file and output should paste in this excel file
end Sub

Answer 1

有多种方法可以将记录集移至Excel，或将数据从Access复制到Excel。

如果要使其最小化：

Dim excelApp
Set excelApp = CreateObject("Excel.Application")
ExcelApp.Workbooks.Add 'New workbook
ExcelApp.Cells(1,1).CopyFromRecordset rsData
ExcelApp.Visible = True

我个人使用以下代码：

Public Sub RecordsetToExcel(rs)
    Dim excelApp
    rs.MoveFirst
    Set excelApp = GetOrCreateObject("Excel.Application")
    excelApp.Visible = True
    excelApp.Workbooks.Add
    excelApp.ActiveSheet.Range("A2").CopyFromRecordset rs
    excelApp.WindowState = -4137 'xlMaximized
    Dim i
    For i = 0 To rs.Fields.Count - 1
        excelApp.ActiveSheet.Cells(1, i + 1).Value = rs.Fields(i).Name
        excelApp.ActiveSheet.Cells(1, i + 1).Columns.AutoFit
    Next
    With excelApp.ActiveSheet.ListObjects.Add(1, excelApp.ActiveSheet.Cells(1, 1).CurrentRegion, , , 1) 'xlSrcRange, xlYes
        .Name = TableName
        .TableStyle = "TableStyleLight1"
    End With
End Sub

GetOrCreateObject是以下函数：

Public Function GetOrCreateObject(Class)
    On Error Resume Next
    Set GetOrCreateObject = GetObject("", Class)
    If err.Number <> 0 Then
         Set GetOrCreateObject = CreateObject(Class)
    End If
End Function

使用hta将数据从Access数据库复制到excel

1 个答案: