Chuyển dữ liệu từ Recordset sang Excel

[hai2hai]

Cách 1: Đây là 1 trong các cách chuyển dữ liệu từ 1 recordset sang 1 sheet trong excel sử dụng OLE Automation:

Requirements:
- Excel được cài đặt
- Add a reference from the Project, References.

Public Sub FillExcel(ByRef Data As ADODB.Recordset)

    Dim intRecords As Integer,  i As Integer
    Dim j As Integer, Row As Integer
    Dim Column As String, Location As String
    
    Set objExcel = New Excel.Application
    PathExcel = App.Path

    If bolFirstReportDone = False Or intReportQuantity = 0 Then
        InitExcel
        objExcel.Workbooks.Open PathExcel & "\Results.xls"
    Else
        objExcel.Workbooks.Open FileExcel
    End If
    
    bookname = objExcel.ActiveWorkbook.Name
    objExcel.Workbooks(bookname).Worksheets("Sheet1").Activate

    If objExcel.Workbooks(bookname).Worksheets("Sheet1").Range("A1") <> "" Then
        objExcel.Workbooks(bookname).Worksheets("Sheet1").Cells.Select
        objExcel.Workbooks(bookname).ActiveSheet.Cells.Clear
    End If
    
    Row = 1 'first row
    Column = 65 'letter A
    Data.MoveLast:               Data.MoveFirst
    intRecords = Data.RecordCount
    
    For i = 0 To Data.Fields.Count - 1
        Data.MoveFirst
        Row = 1
        Location = Chr(Column) + Trim(Str(Row))
        objExcel.Workbooks(bookname).Worksheets("Sheet1").Range(Location). _
                 FormulaR1C1 = Data.Fields(i).Name
        Row = 2

        For j = 0 To (intRecords - 1)
            Location = Chr(Column) + Trim(Str(Row + j))

            If IsNumeric(Data.Fields(i)) Then
                objExcel.Workbooks(bookname).Worksheets("Sheet1"). _
                       Range(Location).Value = Data.Fields(i)
            Else
                objExcel.Workbooks(bookname).Worksheets("Sheet1"). _
                         Range(Location).FormulaR1C1 = Data.Fields(i)
            End If

            Data.MoveNext
        Next j

        'autofit'
        objExcel.Workbooks(bookname).Worksheets("Sheet1"). _
               Columns(Chr(Column) & ":" & Chr(Column)).EntireColumn.AutoFit

        If Data.Fields(i).Name = strDateField Then
            Location = Chr(Column) & "2" & ":" & Chr(Column) & Trim(Str(j + 1))
            objExcel.Workbooks(bookname).Worksheets("Sheet1").Range _
                      (Location).NumberFormat = "mmm-yy"
        End If

        Column = Column + 1
    Next i

End Sub


Private Sub InitExcel()

    PathExcel = App.Path
    FileExcel = PathExcel & "\" & Format(Now(), "yyyyummudduHhuNnuSs") & ".xls"
End Sub

Tuy nhiên, với cách làm này (sử dụng Excel.Application, Excel.Workbook và Excel.Worksheet) thì ta gặp phải những vấn đề sau:
- Sẽ rất chậm vì Excel chiếm rất nhiều resources của windows (bộ nhớ, filepage, cpu usages, v.v...). Đặc biệt nếu dữ liệu quá lớn thì gần như ko thể sử lý nổi (với vài chục nghìn bản ghi thôi là Excel đã lăn quay ra rồi)
- Không tương thích với mọi version của Windows, của MS Office.

Cách 2: Để khắc phục các nhược điểm trên, ta có thể sử dụng 1 đoạn code khác như sau:

Function CreateExcelFile() As Long

    On Error Goto CatchErr
    
    Const LF_SYMBOL As Byte = &HA
    Const TAB_SYMBOL As Byte = &H9
    Dim szFilePath As String, szFileName As String
    Dim szDefaultBuffer As String
    Dim lFieldCount As Long, lRowCount As Long
    Dim ltempCount As Long, ltempCount2 As Long
    szFilePath = App.Path
    If Right(szFilePath, 1) <> "\" Then szFilePath = szFilePath & "\"
    szFileName = "TestExcel"
    lFieldCount = 10:                       lRowCount = 10
    Open szFilePath & szFileName & ".xls" For Append As #1
    szDefaultBuffer = ""
    
   [COLOR="Blue"] 'save field names[/COLOR]
    ltempCount = 1

    Do While ltempCount <= lFieldCount
        szDefaultBuffer = szDefaultBuffer & Chr(TAB_SYMBOL) & "Field" & ltempCount
        ltempCount = ltempCount + 1
    Loop

 [COLOR="blue"]   'can be skipped because Print put that symbol
    'szDefaultBuffer=szDefaultBuffer & chr(LF_SYMBOL)[/COLOR]   
    Print #1, szDefaultBuffer
    'save field values
    ltempCount = 1

    Do While ltempCount <= lRowCount
        
        szDefaultBuffer = "":                      ltempCount2 = 1
        
        Do While ltempCount2 <= lFieldCount
            szDefaultBuffer = szDefaultBuffer & Chr(TAB_SYMBOL) & "Value" _
                  & ltempCount & ":" & ltempCount2
            ltempCount2 = ltempCount2 + 1
        Loop

 [COLOR="blue"]       'can be skipped because Print put that symbol
        'szDefaultBuffer=szDefaultBuffer & chr(LF_SYMBOL)[/COLOR]
        
        Print #1, szDefaultBuffer
        
        ltempCount = ltempCount + 1
    Loop

    Close 1
    
    CreateExcelFile = 0
    Exit Function
    CatchErr:
    CreateExcelFile = Err.Number
End Function

Dĩ nhiên còn nhiều cách khác mà mọi người có thể nghĩ ra để thực hiện công việc trên.

Cheers!

 

[minhhsla]

Chào các bạn mình đang làm chương trình VB6.0 CSDL Access 2003, xin cho mình hỏi làm cách nào để xuất dữ liệu từ một Recorset ra một bảng tinh Excel mà bảng bảng tính này được đặt tên sẵn, lưu vào đường dẫn đặt sẵn, định dạng Font và khung sẵn.
Xuất ra một file Excel thô thì mình đã làm được