Copy dữ liệu từ Access - Copy data from an Access database into Excel with ADO

[levanduyet]

Chắc chắn rằng có rất nhiều câu hỏi trên diễn đàn về việc nhập dữ liệu từ Access vào Excel.
Trong bài này tác giả - Ron de Bruin sẽ giới thiệu với chúng ta việc sử dụng ADO để làm việc trên.

Các bước làm việc với CSDL Access để lấy dữ liệu trong các bảng (table) Access vào Excel như sau:
(Dĩ nhiên là các bạn phải biết được đường dẫn đến tập tin Access *.mdb, password, các bảng các bạn cần lấy cũng như cấu trúc của các bảng này)

1. Bước 1: Kết nối với CSDL. Để làm được điều này các bạn có thể tham khảo Link 1, Link 2 .
2. Bước 2:Sau khi kết nối CSDL, lấy dữ liệu và đưa ra một biến Recordset.
3. Bước 3: Đưa dữ liệu từ biến Recordset này vào Excel và định dạng nếu cần.
4. Bước 4: Đóng kết nối với CSDL. Công việc hoàn tất.

Các bạn có thể xem tập tin OrderDatabase.mdb và các tập tin ví dụ trong tập tin đính kèm trong topic này.
Với chú ý: workbooks và tập tin OrderDatabase.mdb phải được đặt trong cùng một thư mục.

Trong CSDL OrderDatabase.mdb có bảng dữ liệu tên Orders với các trường sau:

• OrderNumber
• OrderDate
• RequiredDate
• ShippedDate
• Freight
• ShipVia
• ShipCountry
• ShipName
• ShipAddress
• ShipCity
• ShipRegion
• ShipPostalCode

Sau đây là một số macro ví dụ, các bạn có thể dùng chúng để lấy chỉ một số record theo ý của bạn:

Hàng đầu tiên: Path/name đường dẫn và tên của tập tin Access, tên bảng (Table)
Hàng thứ hai: Các bạn có thể đưa vào 7 tiêu chí để lọc, nếu bạn không đưa vào thì tất cả các bản ghi (records) sẽ được trả về.
Ba tiêu chí đầu tiên chỉ cho trường dữ liệu dạng Text.
Tiêu chí thứ tư và thứ năm cho trường dữ liệu dạng số.
Tiêu chí thứ sáu và thứ bảy cho trường dữ liệu dạng ngày (date)
Hàng thứ chín: Sheet/Vùng đích (tức là sheet bạn muốn đưa dữ liệu ra) (Destination sheet/range)
Hàng thứ mười: Trường nào ( * = all), Copy tên field (field names), xóa tất cả các ô ở sheet đích trước.


Chú ý: Nếu bạn sử dụng từ 4 đến 7 tiêu chí (dạng số hoặc dạng ngày) bạn có thể thay đổi >, <, >=, <= để lấy về kết quả bạn muốn.
Ví dụ 1.

Sub Test1()
'Ví dụ này lấy dữ liệu với điều kiện  [COLOR="Blue"]ShipCountry = Germany[/COLOR]
    GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
                      "ShipCountry", "=", "Germany", _
                      "", "=", "", _
                      "", "=", "", _
                      "", ">", "", _
                      "", "<", "", _
                      "", ">=", "", _
                      "", "<=", "", _
                      Sheets("test").Range("A8"), _
                      "*", True, True
End Sub

Ví dụ 2.

Sub Test2()
'Ví dụ này cũng lấy dữ liệu với điều kiện [COLOR="Blue"]ShipCountry = Germany[/COLOR]
'Nhưng nó chỉ lấy 4 trường dữ liệu là : [COLOR="Blue"]OrderNumber, ShipName, ShipAddress, ShipPostalCode[/COLOR]
'
    GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
                      "ShipCountry", "=", "Germany", _
                      "", "=", "", _
                      "", "=", "", _
                      "", ">", "", _
                      "", "<", "", _
                      "", ">=", "", _
                      "", "<=", "", _
                      Sheets("test").Range("A8"), _
                      "OrderNumber, ShipName, ShipAddress, ShipPostalCode", True, True
End Sub

Ví dụ 3.

Sub Test3()
'Ví dụ này lấy dữ liệu với điều kiện 
'[COLOR="Blue"]ShipCountry = Germany[/COLOR] và [COLOR="Blue"]ShipVia = Speedy Express[/COLOR]
    GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
                      "ShipCountry", "=", "Germany", _
                      "ShipVia", "=", "Speedy Express", _
                      "", "=", "", _
                      "", ">", "", _
                      "", "<", "", _
                      "", ">=", "", _
                      "", "<=", "", _
                      Sheets("test").Range("A8"), _
                      "*", True, True
End Sub

Ví dụ 4.

Sub Test4()
'Ví dụ này lấy dữ liệu với điều kiện
'[COLOR="Blue"]ShipCountry = Germany[/COLOR] và [COLOR="Blue"]ShipVia = Speedy Express[/COLOR]
'và [COLOR="Blue"]Freight [/COLOR]có giá trị [COLOR="Blue"]từ 100 đến 300[/COLOR]

    GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
                      "ShipCountry", "=", "Germany", _
                      "ShipVia", "=", "Speedy Express", _
                      "", "=", "", _
                      "Freight", ">", "100", _
                      "Freight", "<", "300", _
                      "", ">=", "", _
                      "", "<=", "", _
                      Sheets("test").Range("A8"), _
                      "*", True, True
End Sub

Ví dụ 5.

Sub Test5()
'Ví dụ này lấy dữ liệu với điều kiện
'[COLOR="Blue"]ShipCountry = Germany[/COLOR] và [COLOR="Blue"]ShipVia = Speedy Express[/COLOR]
'và [COLOR="Blue"]ShippedDate [/COLOR]có giá trị [COLOR="Blue"]từ ngày 1/1/1998 đến ngày 3/1/1998[/COLOR]

    GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
                      "ShipCountry", "=", "Germany", _
                      "ShipVia", "=", "Speedy Express", _
                      "", "=", "", _
                      "", ">", "", _
                      "", "<", "", _
                      "ShippedDate", ">=", "1/1/1998", _
                      "ShippedDate", "<=", "3/1/1998", _
                      Sheets("test").Range("A8"), _
                      "*", True, True
End Sub

Ví dụ 6.

Sub Test6()
'Ví dụ này lấy tất cả các bảng ghi (records)
    GetDataFromAccess ThisWorkbook.Path & "/OrderDatabase.mdb", "Orders", _
                      "", "=", "", _
                      "", "=", "", _
                      "", "=", "", _
                      "", ">", "", _
                      "", "<", "", _
                      "", ">=", "", _
                      "", "<=", "", _
                      Sheets("test").Range("A8"), _
                      "*", True, True
End Sub

Và đây là macro tổng quát

Public Sub GetDataFromAccess(MyDatabaseFilePathAndName As String, MyTable As String, _
                             MyTableField1 As String, S1 As String, MyFieldValue1 As String, _
                             MyTableField2 As String, S2 As String, MyFieldValue2 As String, _
                             MyTableField3 As String, S3 As String, MyFieldValue3 As String, _
                             MyTableField4 As String, S4 As String, MyFieldValue4 As String, _
                             MyTableField5 As String, S5 As String, MyFieldValue5 As String, _
                             MyTableField6 As String, S6 As String, MyFieldValue6 As String, _
                             MyTableField7 As String, S7 As String, MyFieldValue7 As String, _
                             DestSheetRange As Range, WhichFields As String, _
                             FieldNames As Boolean, ClearRange As Boolean)

 

'
'Thêm option [COLOR="Blue"]WhichFields [/COLOR]để copy chỉ các trường dữ liệu bạn muốn

 

    Dim MyConnection As String
    Dim MySQL As String
    Dim MyDatabase As Object
    Dim col As Integer
    Dim I As Integer
    Dim str1 As Variant
    Dim str2 As Variant
    Dim str3 As Variant
    

    '[COLOR="Red"]Chuẩn bị sheet để đưa dữ liệu ra[/COLOR]
    '
    'Chọn [COLOR="Blue"]DestSheetRange [/COLOR]nơi bạn đưa dữ liệu ra
    Application.Goto DestSheetRange

    '[COLOR="Blue"]Nếu biến ClearRange = True thì xóa dữ liệu trước[/COLOR]
    If ClearRange Then Range(DestSheetRange.Address, "IV" & Rows.Count).ClearContents

    '********************************
    ' [B][COLOR="Red"]BƯỚC 1[/COLOR][/B]
    '********************************
    'Tạo chuỗi kết nối ([COLOR="Blue"]connection string[/COLOR])
    MyConnection = "Provider=Microsoft.Jet.OLEDB.4.0;"
    MyConnection = MyConnection & "Data Source=" & MyDatabaseFilePathAndName & ";"

    ' Tạo chuỗi [COLOR="Blue"]MySQL[/COLOR]
    str1 = Array(MyTableField1, MyTableField2, MyTableField3, MyTableField4, MyTableField5, MyTableField6, MyTableField7)
    str2 = Array(S1, S2, S3, S4, S5, S6, S7)
    str3 = Array(MyFieldValue1, MyFieldValue2, MyFieldValue3, MyFieldValue4, MyFieldValue5, MyFieldValue6, MyFieldValue7)

    MySQL = ""
    For I = LBound(str1) To UBound(str1)
        If str3(I) <> "" Then
            If MySQL = "" Then
                If I <= 2 Then
                    MySQL = "SELECT " & WhichFields & " FROM " & MyTable & " WHERE [" _
                            & str1(I) & "] " & str2(I) & " '" & str3(I) & "'"
                ElseIf I = 3 Or I = 4 Then
                    MySQL = "SELECT " & WhichFields & " FROM " & MyTable & " WHERE [" _
                            & str1(I) & "] " & str2(I) & " " & str3(I)

                ElseIf I = 5 Or I = 6 Then
                    MySQL = "SELECT " & WhichFields & " FROM " & MyTable & " WHERE [" _
                            & str1(I) & "] " & str2(I) & " #" & str3(I) & "#"
                End If

            Else
                If I <= 2 Then
                    MySQL = MySQL & " and [" & str1(I) & "] " & str2(I) & " '" & str3(I) & "'"
                ElseIf I = 3 Or I = 4 Then
                    MySQL = MySQL & " and [" & str1(I) & "] " & str2(I) & " " & str3(I)
                ElseIf I = 5 Or I = 6 Then
                    MySQL = MySQL & " and [" & str1(I) & "] " & str2(I) & " #" & str3(I) & "#"
                End If
            End If
        End If
    Next I

    'Nếu MySQL là rỗng (empty) thì copy tất cả các bản ghi
    If MySQL = "" Then MySQL = "SELECT " & WhichFields & " FROM " & MyTable & ";"

    '********************************
    ' [B][COLOR="Red"]BƯỚC 2[/COLOR][/B]
    '********************************

    'Bắt đầu mở CSDL và copy dữ liệu
    On Error GoTo SomethingWrong
    Set MyDatabase = CreateObject("adodb.recordset")
    MyDatabase.Open MySQL, MyConnection, 0, 1, 1

    '********************************
    ' [B][COLOR="Red"]BƯỚC 3[/COLOR][/B]
    '********************************

    'Kiểm tra để chắc chắn rằng chúng ta đã nhận dữ liệu và copy dữ liệu
    'Ở đây là kiểm tra [COLOR="Blue"]Recordset[/COLOR]
    If Not MyDatabase.EOF Then
        'If FieldNames = True copy the field names and records
        'If = False copy only records
        '[B][COLOR="Red"]Chú ý quan trọng[/COLOR][/B]
        [COLOR="Red"]' Đối với phiên bản EXCEL 2000,2002,2003, or 2007
        ' thì các bạn có thể dùng phương thức [B]CopyFromRecordset [/B]của
        ' Còn đối với Excel 97 thì các bạn phải dùng phương thức [B]Getrows [/B]của đối tượng Recordset[/COLOR]
        ' Các bạn tham khảo ví dụ kế tiếp
        ' [B][COLOR="Red"]RecordsetToRange[/COLOR][/B]
        If FieldNames Then
            For col = 0 To MyDatabase.Fields.Count - 1
                DestSheetRange.Offset(0, col).Value = MyDatabase.Fields(col).Name
            Next
            DestSheetRange.Offset(1, 0).CopyFromRecordset MyDatabase
        Else
            DestSheetRange.CopyFromRecordset MyDatabase
        End If


    Else
        MsgBox "No records returned from : " & MyDatabaseFilePathAndName, vbCritical
    End If

    '********************************
    ' [B][COLOR="Red"]BƯỚC 4[/COLOR][/B]
    '********************************


    MyDatabase.Close
    Set MyDatabase = Nothing
    Exit Sub

SomethingWrong:
    On Error GoTo 0
    Set MyDatabase = Nothing
    MsgBox "Error copying data", vbCritical, "Test Access data to Excel"

End Sub

Gợi ý:
Thay vì đưa vào giá trị của trường dữ liệu (field) trong đoạn mã, bạn cũng có thể sử dụng giá trị của một ô (cell) như sau:

"ShipVia", "=", Sheets("Sheet1").Range("A2").Value

Nguồn từ đây.
Các bạn có thể tham khảo sách ADO tiếng việt ở đây.
Ngoài ra các bạn có thể tham khảo các bài sau trên diễn đàn:

• ADODB và việc kết nối Excel và Access trong công tác kế toán.
• ADO: Kết nối Excel Database cho công việc kế toán.
• Chuyển dữ liệu từ Recordset sang Excel.
• Cập nhật theo lô - Batch update. Ngoài ra link này còn so sánh giúp bạn trong việc khai báo kiểu biến như thế nào để chương trình của bạn thực thi được nhanh hơn.

Chúc các bạn một ngày lễ 1/5 vui.

Lê Văn Duyệt

 

[levanduyet]

Thủ tục RecordsetToRange - RecordsetToRange routine

Như trên đã nói, việc dùng phương thức CopyFromRecordset của Recordset chỉ được dùng đối với phiên bản Excel từ Excel 2000 trở lên. Còn đối phiên bản Excel 97 thì phải dùng phương thức Getrows của Recordset để xuất dữ liệu ra.

Sau đây là một thủ tục nhằm xuất dữ liệu ra Excel từ đối tượng Recordset, có kiểm tra phiên bản của Excel mà dùng phương thức cho phù hợp

Sub [B][COLOR="Red"]RecordsetToRange[/COLOR][/B](Rst As Object, WsName As String)


    Dim xlWb As Workbook
    Dim xlWs As Worksheet

    Dim fldCount As Long, recCount As Long
    Dim iCol As Integer, iRow As Long
    Dim recArray As Variant


    On Error GoTo ErrorHandler

    If Rst Is Nothing Then    'tức là nếu bạn không khởi tạo biến recordset
        MsgBox "Bạn chưa tạo recordset.", vbOKOnly, "Thông báo"
        GoTo ErrorExit
    End If
    ' Sau đó kiểm tra biến Recordset Rst
    If Rst.EOF And Rst.BOF Then
        MsgBox "Không có bản ghi nào để xuất ra.", vbOKOnly, "Thông báo"
        GoTo ErrorExit
    End If
    If Rst.RecordCount = 0 Then
        MsgBox "Không có bản ghi nào để xuất ra.", vbOKOnly, "Thông báo"
        GoTo ErrorExit
    Else
        MsgBox "Số bản ghi xuất ra là : " & Rst.RecordCount, vbOKOnly, "Thông báo"
    End If
    'Kiểm tra worksheet
    If Not SheetExists(WsName) Then
        MsgBox "Worksheet không tồn tại." & vbCrLf & _
               "Please check again.", vbOKOnly, "Thông báo"
        GoTo ErrorExit
    End If
    ' Khởi tạo biến workbook, worksheet
    Set xlWb = Application.ThisWorkbook
    Set xlWs = xlWb.Worksheets(WsName)
    ' Xóa dữ liệu trước khi đưa dữ liệu ra
    xlWs.Cells.Clear    
    ' Đưa tên trường dữ liệu ra ở hàng trên cùng
    fldCount = Rst.fields.Count
    For iCol = 1 To fldCount
        xlWs.Cells(1, iCol).Value = Rst.fields(iCol - 1).Name
    Next

    ' Kiểm tra phiên bản của Excel để dùng phương thức cho phù hợp
    If Val(Mid(Application.Version, 1, InStr(1, Application.Version, ".") - 1)) > 8 Then
        'EXCEL 2000,2002,2003, or 2007: Use CopyFromRecordset

        ' Đưa dữ liệu ra worksheet, bắt đầu ở ô A2
        xlWs.Cells(2, 1).CopyFromRecordset Rst
        [COLOR="Blue"]'Note: CopyFromRecordset will fail if the recordset
        'contains an OLE object field or array data such
        'as hierarchical recordsets
[/COLOR]
    Else
        'EXCEL 97 or earlier: Sử dụng GetRows và copy ra một mảng rồi đưa vào Excel

        ' Copy recordset vào một mảng
        recArray = Rst.getrows
       [COLOR="Blue"] 'Note: GetRows returns a 0-based array where the first
        'dimension contains fields and the second dimension
        'contains records. We will transpose this array so that
        'the first dimension contains records, allowing the
        'data to appears properly when copied to Excel[/COLOR]

        ' Xác định số bản ghi
        recCount = UBound(recArray, 2) + 1    '+ 1 since 0-based array

        ' Check the array for contents that are not valid when
        ' copying the array to an Excel worksheet
        For iCol = 0 To fldCount - 1
            For iRow = 0 To recCount - 1
                ' Take care of Date fields
                If IsDate(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = Format(recArray(iCol, iRow))
                    ' Take care of OLE object fields or array fields
                ElseIf IsArray(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = "Array Field"
                End If
            Next iRow    'next record
        Next iCol    'next field

        ' Transpose and Copy the array to the worksheet,
        ' starting in cell A2
        xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = _
        TransposeDim(recArray)
    End If

    ' Auto-fit the column widths and row heights

    With xlWs.Cells
        .Columns.AutoFit
        .Rows.AutoFit
    End With

ErrorExit:
    ' Đóng Recordset và giải phóng bộ nhớ
    Rst.Close
    Set Rst = Nothing 
    Set xlWs = Nothing
    Set xlWb = Nothing
    Exit Sub

ErrorHandler:

    'Nếu có lỗi xãy ra thì thực hiện việc ghi lại tùy người dùng
    'Sau đó trở lại chương trình chính 
    Resume ErrorExit

End Sub

Private Function [COLOR="Red"][B]TransposeDim[/B][/COLOR](V As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)

    Dim x As Long, y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant

    Xupper = UBound(V, 2)
    Yupper = UBound(V, 1)

    ReDim tempArray(Xupper, Yupper)
    For x = 0 To Xupper
        For y = 0 To Yupper
            tempArray(x, y) = V(y, x)
        Next y
    Next x
    TransposeDim = tempArray

End Function

Các bạn chú ý các đoạn ghi chú tiếng Anh. Đây là các chú ý quan trọng.

Chú ý: về việc dùng Transpose và giới hạn của nó các bạn có thể tham khảo tại:

• Link 1.
• Link 2.
• Link 3.

Lê Văn Duyệt