Kết nối, Thao tác giữa Excel và Access

[levanduyet]

Hi em,

Em nên đọc quyển ADO toàn tập. Chứ hỏi kiểu này bao giờ mới kết thúc đây. (Chắc tính tiền từng câu hỏi, thì sẽ không hỏi nữa...ha ha ha)

Để làm việc đó, em thay câu lệnh SQL
và dùng phương thức

Execute

của Command để thực thi. Khi thực thi số bản ghi bị xoá sẽ được đưa vào biến lEff (em nhớ khai báo biến Dim lEff As Long)
Sau đó thông báo số bản ghi bị xoá.

        sSQL = "DELETE* FROM TB_NhanVien " & _
               "WHERE GioiTinh='Nam';"

        Set adoCommand = CreateObject("ADODB.Command")
        With adoCommand
            .CommandType = 1                          '1: adCmdText, 2: adCmdTable, 4: adCmdStoredProc
            .ActiveConnection = gcnObj
            .CommandText = sSQL
            .Execute lEff
        End With

        MsgBox " Co " & lEff & " ban ghi bi xoa.", vbOKOnly + vbInformation, gcsAppName

Trong ví dụ trên em nên thêm thủ tục để đóng kết nối

Sub DongKetNoi()
    Set gcnObj = Nothing
End Sub

Rồi em sẽ gọi thủ tục này trước khi đóng Workbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call DongKetNoi
End Sub

Lê Văn Duyệt

 

[Hoàng Trọng Nghĩa]

Hi em,

Em nên đọc quyển ADO toàn tập. Chứ hỏi kiểu này bao giờ mới kết thúc đây. (Chắc tính tiền từng câu hỏi, thì sẽ không hỏi nữa...ha ha ha)


Lê Văn Duyệt

Kakaka, định hỏi dồn một lượt rồi qua cái chỗ hôm bữa nhậu dưới mưa làm với Anh một chầu luôn cho nó đeeeeeeeeeeeẽ ! Nói thiệt là nhờ Anh mà em vọc cũng khá nhiều đó, lỗi lên, lỗi xuống kết quả cũng được 3 đúng 7 sai! kakakaka

 

[levanduyet]

Kakaka, định hỏi dồn một lượt rồi qua cái chỗ hôm bữa nhậu dưới mưa làm với Anh một chầu luôn cho nó đeeeeeeeeeeeẽ ! Nói thiệt là nhờ Anh mà em vọc cũng khá nhiều đó, lỗi lên, lỗi xuống kết quả cũng được 3 đúng 7 sai! kakakaka

Coi bộ cái vụ này được à nhen.

Lê Văn Duyệt

 

[Hoàng Trọng Nghĩa]

Đây là UDF để reset lại trường dạng Autonumber:

Function ChangeSeed(strTbl As String, strCol As String, lngSeed As Long) As Boolean
'strTbl = Ten Table co chua truong kieu autonumber
'strCol = Ten truong co chua autonumber
'lngSeed = Con so ma ban muon no hien thi cho dong ke tiep.

Dim cnn As ADODB.Connection
Dim cat As New ADOX.Catalog
Dim col As ADOX.Column

Set cnn = CurrentProject.Connection
cat.ActiveConnection = cnn

Set col = cat.Tables(strTbl).Columns(strCol)

col.Properties("Seed") = lngSeed
cat.Tables(strTbl).Columns.Refresh
If col.Properties("seed") = lngSeed Then
    ChangeSeed = True
Else
    ChangeSeed = False
End If
Set col = Nothing
Set cat = Nothing
Set cnn = Nothing

End Function

Lưu ý: Nhớ check vào Microsoft ADO Ext 2.x for DDL and Security Libraries trong Tools, References

Xin cho hỏi, Hàm này vận dụng như thế nào vậy? Cám ơn.

 

[levanduyet]

Xin tán gẫu một tí:

Tên hàm: ChangeSeed = Change (thay đổi) + Seed (Hạt giống/Tinh dịch/Con cháu...)

Ghép lại sao thấy nó kỳ kỳ sao đó. Hi hi hi.

Lê Văn Duyệt

 

[Hai Lúa Miền Tây]

Xin cho hỏi, Hàm này vận dụng như thế nào vậy? Cám ơn.

Trong Excel thì anh sử dụng như sau:

1.) Trong Module:

Function ChangeSeed(strTbl As String, strCol As String, lngSeed As Long) As Boolean
'strTbl = Ten Table co chua truong kieu autonumber
'strCol = Ten truong co chua autonumber
'lngSeed = Con so ma ban muon no hien thi cho dong ke tiep.
'Dim cnn As ADODB.Connection
Dim cat As New ADOX.Catalog
Dim col As ADOX.Column
'Set cnn = CurrentProject.Connection
cat.ActiveConnection = cnn
Set col = cat.Tables(strTbl).Columns(strCol)
col.Properties("Seed") = lngSeed
cat.Tables(strTbl).Columns.Refresh
If col.Properties("seed") = lngSeed Then
    ChangeSeed = True
Else
    ChangeSeed = False
End If
Set col = Nothing
Set cat = Nothing
Set cnn = Nothing
End Function

2.) Chạy Sub sau: Nó sẽ reset trường STT lên 600, nếu anh nhập tiếp thì nó sẽ bắt đầu STT mới là 601

Sub ChinhSo()
Moketnoi
Call ChangeSeed("TB_NhanVien", "STT", 600)
End Sub

 

[Hoàng Trọng Nghĩa]

Trong Excel thì anh sử dụng như sau:


2.) Chạy Sub sau: Nó sẽ reset trường STT lên 600, nếu anh nhập tiếp thì nó sẽ bắt đầu STT mới là 601

Sub ChinhSo()
Moketnoi
Call ChangeSeed("TB_NhanVien", "STT", 600)
End Sub

Sao thử chạy thủ tục trên mà STT chẳng nhúc nhích gì vậy? Dù anh mở hay đóng Acc cũng không thay đổi?

Như vầy nha, lúc xóa hết dữ liệu trong Acc, sau đó nhập dữ liệu mới, thì số đầu tiên của nó hiện tại là 110 và số cuối cùng là 152, vậy thì reset về số đầu tiên là 1 thì không được.

 

[Hai Lúa Miền Tây]

Sao thử chạy thủ tục trên mà STT chẳng nhúc nhích gì vậy? Dù anh mở hay đóng Acc cũng không thay đổi?

Như vầy nha, lúc xóa hết dữ liệu trong Acc, sau đó nhập dữ liệu mới, thì số đầu tiên của nó hiện tại là 110 và số cuối cùng là 152, vậy thì reset về số đầu tiên là 1 thì không được.

Ý anh là cái số thứ tự trong các dòng phải reset lại Từ 1 -> n? Nếu vậy thì anh chỉ có cách là làm tay là xoá trường đó đi rồi tạo lại trường mới.
Code trên chỉ reset lại khi thêm dữ liệu mới ví dụ trong bảng dữ liệu hiện thời trường STT đánh đến 200 hay n gì đó nếu anh reset lại n=1 thì dòng cập nhật kế tiếp sẽ là n+1. Còn nếu không muốn thì anh bỏ hẳn trường STT này dạng AutoNumber thành dạng number đi rồi dùng code đánh số thứ tự nó lại.

 

[levanduyet]

Ý anh là cái số thứ tự trong các dòng phải reset lại Từ 1 -> n? Nếu vậy thì anh chỉ có cách là làm tay là xoá trường đó đi rồi tạo lại trường mới.
Code trên chỉ reset lại khi thêm dữ liệu mới ví dụ trong bảng dữ liệu hiện thời trường STT đánh đến 200 hay n gì đó nếu anh reset lại n=1 thì dòng cập nhật kế tiếp sẽ là n+1. Còn nếu không muốn thì anh bỏ hẳn trường STT này dạng AutoNumber thành dạng number đi rồi dùng code đánh số thứ tự nó lại.

Thấy không em, rắc rối mà "cứ đòi làm". Có tác dụng gì đâu.

Lê Văn Duyệt

 

[Hoàng Trọng Nghĩa]

Sub AccessToExcel()
    Dim lCon  As Long
    Dim sSQL  As String
    Dim adoCommand As Object                          'ADODB.Command
    Dim oRs   As Object                               'ADODB.Recordset
    Dim wsObj As Worksheet
    Dim lLastRow As Long


    Set wsObj = Application.ThisWorkbook.Worksheets("FilterFromAccess")
    lLastRow = FindLastRow(wsObj)
    lCon = KetNoi
    If lCon <> 1 Then
        MsgBox "Khong the ket noi voi CSDL." & vbCrLf & _
               "Xuat du lieu khong thanh cong.", vbOKOnly + vbInformation, gcsAppName
    Else
        ' Mo ket noi
        gcnObj.Open
[COLOR=#ff0000][B]        sSQL = "SELECT MaSo, HoTen, NgaySinh, GioiTinh, NgayNhap " & _[/B][/COLOR]
               "FROM TB_NhanVien " & _
               "WHERE MaSo='" & "HTN005" & "';"
        Set adoCommand = CreateObject("ADODB.Command")
        With adoCommand
            .CommandType = 1                          '1: adCmdText, 2: adCmdTable, 4: adCmdStoredProc
            .ActiveConnection = gcnObj
            .CommandText = sSQL
        End With
        Set oRs = CreateObject("ADODB.Recordset")
        oRs.Open adoCommand, , 3, 4
        If oRs.EOF Then
            MsgBox "Khong co record nao thoa dieu kien.", vbOKOnly + vbInformation, gcsAppName
        Else
            wsObj.Cells(lLastRow + 1, 1).CopyFromRecordset oRs
        End If

    End If

ErrorExit:
    Set adoCommand = Nothing
    Set oRs = Nothing
    Set wsObj = Nothing
    If Not gcnObj Is Nothing Then
        If (gcnObj.State And adStateOpen) = adStateOpen Then
            gcnObj.Close
        End If
    End If
    Exit Sub

ErrorHandle:
    ' Xu ly loi tai day
    MsgBox "Co loi xay ra. Xin kiem tra lai.", vbOKOnly + vbInformation, gcsAppName
    Debug.Print Err.Number & ", " & Err.Description
    Resume ErrorExit
End Sub

Lê Văn Duyệt

Anh Duyệt ơi, chỗ em tô màu đỏ ấy, nếu như có chừng 50 trường thì mình gõ đủ 50 trường luôn hay dùng thủ tục nào đó ngắn hơn như 1 to 50 gì gì đó được không?

 

[Hai Lúa Miền Tây]

Anh Duyệt ơi, chỗ em tô màu đỏ ấy, nếu như có chừng 50 trường thì mình gõ đủ 50 trường luôn hay dùng thủ tục nào đó ngắn hơn như 1 to 50 gì gì đó được không?

Nếu anh chọn các trường trong 1 bảng theo thứ tự và chọn lọc theo ý muốn thì phải gõ tay. Còn nếu như chọn tất cả các trường trong 1 bảng thì chỉ việc đánh dấu * thay cho tất cả các trường.
Ví dụ:

"SELECT * FROM TB_NhanVien "

Thì nó sẽ chọn tất cả các trường của bảng TB_NhanVien

Anh Viết:

sSQL = "SELECT MaSo, HoTen, NgaySinh, GioiTinh, NgayNhap " & _
"FROM TB_NhanVien " & _
"WHERE MaSo='" & "HTN005" & "';"

Theo như đoạn trên thì anh không cần phải thêm mấy dấu & vào ngay cái chuổi mã mà anh muốn lọc.

sSQL = "SELECT MaSo, HoTen, NgaySinh, GioiTinh, NgayNhap " & _
"FROM TB_NhanVien " & _
"WHERE MaSo like 'HTN005';"

 

[Hoàng Trọng Nghĩa]

Nếu anh chọn các trường trong 1 bảng theo thứ tự và chọn lọc theo ý muốn thì phải gõ tay. Còn nếu như chọn tất cả các trường trong 1 bảng thì chỉ việc đánh dấu * thay cho tất cả các trường.
Ví dụ:

Thì nó sẽ chọn tất cả các trường của bảng TB_NhanVien

Anh Viết:

Theo như đoạn trên thì anh không cần phải thêm mấy dấu & vào ngay cái chuổi mã mà anh muốn lọc.

Làm ơn cho hỏi thêm lần nữa là nếu mình muốn lấy luôn tiêu để sau khi lọc thì phải làm thế nào?

 

[Hai Lúa Miền Tây]

Làm ơn cho hỏi thêm lần nữa là nếu mình muốn lấy luôn tiêu để sau khi lọc thì phải làm thế nào?

Anh Dùng code sau:

Sub ToExcel()
Dim mySQL As String: Dim iNumCols As Integer
Moketnoi
Dim rst  As New ADODB.Recordset
  mySQL = "SELECT * from csdl"
  rst.Open mySQL, cnn, 1, 3
    iNumCols = rst.Fields.Count
    For i = 1 To iNumCols
        With AccFilter
            .Cells(1, i).Value = rst.Fields(i - 1).Name
            .Cells(1, i).Font.Bold = True
            .Cells(1, i).Font.ColorIndex = 5
            With .Cells(1, i).Interior
                .ColorIndex = 34
            End With
           
        End With
    Next
     AccFilter.Cells(2, "A").CopyFromRecordset rst
 Set rst = Nothing
 cnn.Close
 Set cnn = Nothing
End Sub

Anh tải file này về rồi chép chung folder với csdl ví dụ ở bài 1 nhé.

 

[Hoàng Trọng Nghĩa]

Anh Dùng code sau:

Sub ToExcel()
Dim mySQL As String: Dim iNumCols As Integer
Moketnoi
Dim rst  As New ADODB.Recordset
  mySQL = "SELECT * from csdl"
  rst.Open mySQL, cnn, 1, 3
    iNumCols = rst.Fields.Count
    For i = 1 To iNumCols
        With AccFilter
            .Cells(1, i).Value = rst.Fields(i - 1).Name
            .Cells(1, i).Font.Bold = True
            .Cells(1, i).Font.ColorIndex = 5
            With .Cells(1, i).Interior
                .ColorIndex = 34
            End With
           
        End With
    Next
     AccFilter.Cells(2, "A").CopyFromRecordset rst
 Set rst = Nothing
 cnn.Close
 Set cnn = Nothing
End Sub

Anh tải file này về rồi chép chung folder với csdl ví dụ ở bài 1 nhé.

Cám ơn Hai Lúa nhiều nhé! Nhưng nếu mình lấy Caption của cột có được không vậy?

 

[Hai Lúa Miền Tây]

Cám ơn Hai Lúa nhiều nhé! Nhưng nếu mình lấy Caption của cột có được không vậy?

Vẫn CSDL bài 1, anh sử dụng code sau:

Sub ToEx1()
Dim strCSDL As String, i As Integer
Dim db As DAO.Database, rs As DAO.Recordset
strCSDL = ThisWorkbook.Path & "\CSDLfromExcel.mdb"
Set db = OpenDatabase(strCSDL)
Set rs = db.OpenRecordset("select * from csdl where GioiTinh like 'Nam'", 4)
 Application.ScreenUpdating = False
 For i = 0 To rs.Fields.Count - 1
    With AccFilter
       .Cells(1, i + 1).Value = rs.Fields(i).Properties("Caption")
       .Cells(1, i + 1).Font.Bold = True
       .Cells(1, i + 1).Font.ColorIndex = 5
        With .Cells(1, i + 1).Interior
           .ColorIndex = 34
        End With
    End With
    
 Next
 AccFilter.Range("A2").CopyFromRecordset rs
 Application.ScreenUpdating = True
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Sub

 

[levanduyet]

Đây là một ví dụ đầy đủ về việc đưa dữ liệu từ Excel sang Access:

Giả sử ta có một bảng dữ liệu trong Excel như sau:

Yêu cầu:
Phải tham chiếu đến thư viện Microsoft ActiveX Data Objects

Sub DB_Insert_via_ADOSQL()
'Author       : Ken Puls (www.excelguru.ca)
'Macro purpose: To add record to Access database using ADO and SQL
'NOTE:  Reference to Microsoft ActiveX Data Objects Libary required

    Dim cnt As New ADODB.Connection, _
            rst As New ADODB.Recordset, _
            dbPath As String, _
            tblName As String, _
            rngColHeads As Range, _
            rngTblRcds As Range, _
            colHead As String, _
            rcdDetail As String, _
            ch As Integer, _
            cl As Integer, _
            notNull As Boolean, _
            sConnect As String

    'Lấy các giá trị đường dẫn đến CSDL được định nghĩa trên sheet
    dbPath = ActiveSheet.Range("B1").Value
    tblName = ActiveSheet.Range("B2").Value
    Set rngColHeads = ActiveSheet.Range("tblHeadings")
    Set rngTblRcds = ActiveSheet.Range("tblRecords")

    'Set the database connection string here
    'Private sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & dbPath & "';"     'For use with *.accdb files
    sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath & ";"     'For use with *.mdb files

    'Concatenate a string with the names of the column headings
    colHead = " ("
    For ch = 1 To rngColHeads.Count
        colHead = colHead & rngColHeads.Columns(ch).Value
        Select Case ch
            Case Is = rngColHeads.Count
                colHead = colHead & ")"
            Case Else
                colHead = colHead & ","
        End Select
    Next ch

    'Mở kết nối đến CSDL
    cnt.Open sConnect
    'Bắt đầu transaction
    On Error GoTo EndUpdate
    cnt.BeginTrans

    'Insert records into database from worksheet table
    For cl = 1 To rngTblRcds.Rows.Count
        'Giả sử rằng bản ghi hoàn toàn rổng
        notNull = False
        rcdDetail = "('"

        'Kiểm tra các trường của bản ghi
        For ch = 1 To rngColHeads.Count
            Select Case rngTblRcds.Rows(cl).Columns(ch).Value

                    'Nếu rổng (empty) thì mở rộng giá trị thành chuổi NULL
                Case Is = Empty
                    Select Case ch
                        Case Is = rngColHeads.Count
                            rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & "NULL)"
                        Case Else
                            rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & "NULL,'"
                    End Select

                    'if not empty, set notNull to true, and append value to string
                Case Else
                    notNull = True
                    Select Case ch
                        Case Is = rngColHeads.Count
                            rcdDetail = rcdDetail & rngTblRcds.Rows(cl).Columns(ch).Value & "')"
                        Case Else
                            rcdDetail = rcdDetail & rngTblRcds.Rows(cl).Columns(ch).Value & "','"
                    End Select
            End Select
        Next ch

        'Nếu bản ghi chỉ chứa các giá trị Null thì không đưa vào bảng
        'ngược lại thì đưa vào bảng
        Select Case notNull
            Case Is = True
                rst.Open "INSERT INTO " & tblName & colHead & " VALUES " & rcdDetail, cnt
            Case Is = False
                'do not insert record
        End Select
    Next cl

EndUpdate:
    'Check if error was encounted
    If Err.Number <> 0 Then
        'Có lỗi xãy ra. Rollback transaction và báo cho người dùng
        On Error Resume Next
        cnt.RollbackTrans
        MsgBox "Có lỗi xãy ra. Cập nhật không thành công!", vbCritical, "Error!"
    Else
        On Error Resume Next
        cnt.CommitTrans
    End If

    'Đóng ADO objects
    cnt.Close
    Set rst = Nothing
    Set cnt = Nothing
    On Error GoTo 0
End Sub

Lê Văn Duyệt

Nguồn: ExcelGuru

 

[Thanhlam2425]

Để kết nối giữa Excel và Access chúng ta có nhiều cách, ở đây tôi dùng ADO.

Để dễ dàng trong việc kết nối tôi có một số hàm sau:

Function TaoChuoiKetNoi() As String

Hàm này dùng để tạo chuổi kết nối.
Các bạn có thể thêm hoặc chỉnh sửa hàm này nhằm tạo chuổi kết nối đến các CSDL khác nhau như: SQL Server, Foxpro, Access,...

Function TaoChuoiKetNoi() As String
    Dim sAppPath As String
    ' Cac ban co the chinh sua tuy theo yeu cau ket noi cua minh
    sAppPath = ThisWorkbook.Path
    TaoChuoiKetNoi = "Driver={Microsoft Access Driver (*.mdb)}; Dbq=" & sAppPath & "\" & DBName & "; UID=Admin; PWD=;"

End Function

Function KetNoi() As Long
Hàm KetNoi, nếu kết nối thành công thì hàm trả về giá trị là 1. Nếu không thành công hàm sẽ trả về giá trị của lỗi.

Function KetNoi() As Long

    On Error GoTo ErrorHandle

    Set gcnObj = CreateObject("ADODB.Connection")
    With gcnObj
        .Mode = 3                                     'i.e adModeReadWrite
        'Neu sau thoi gian nay ma khong ket noi duoc se bao loi
        .ConnectionTimeout = 30
        'CursorTypeEnum
        '--------------
        'adOpenDynamic     = 2
        'adOpenForwardOnly = 0
        'adOpenKeySet      = 1
        'adOpenStatic      = 3

        'The CursorLocationEnum:
        '-------------------------
        'adUseClient = 3 | Uses client-side cursors supplied by a local cursor library.
        'Local cursor services often will allow many features
        'that driver-supplied cursors may not,
        'so using this setting may provide an advantage
        'with respect to features that will be enabled.
        'For backward compatibility, the synonym adUseClientBatch is also supported.
        'adUseServer = 2 | Default. Uses cursors supplied by the data provider or driver.
        'These cursors are sometimes very flexible and allow
        'for additional sensitivity to changes others make to the data source.
        'However, some features of the The Microsoft Cursor Service for OLE DB,
        'such as disassociated
        'Recordset objects, cannot be simulated with server-side cursors
        'and these features will be unavailable with this setting.
        'adUseNone   = 1 | Does not use cursor services. (
        'This constant is obsolete and appears solely for the sake of backward compatibility.)
        .CursorLocation = 3
        .ConnectionString = TaoChuoiKetNoi
        .Open
    End With
    ' Neu thanh cong dat gia tri ham bang 1
    KetNoi = 1
    ' Dong ket noi lai
    gcnObj.Close

ErrorExit:

    Exit Function

ErrorHandle:
    ' Neu co loi thi dat ma loi cho ham KetNoi
    KetNoi = Err.Number
    Err.Clear
    Resume ErrorExit

End Function

Và sau đây là thủ tục xuất dữ liệu từ Excel sang Access:

Sub ExcelToAccess()

    Dim lLastRow As Long, i As Long
    Dim wsObj As Worksheet
    Dim arrFieldNames As Variant, arrValues As Variant, arrRecordvals As Variant
    Dim sTableName As String
    Dim lCon  As Long
    Dim oRs   As Object

    On Error GoTo ErrorHandle


    sTableName = "TB_NhanVien"

    Set wsObj = Application.ThisWorkbook.Worksheets("CSDL")
    lLastRow = FindLastRow(wsObj)

    If lLastRow = 1 Then
        ' Neu hang bang 1
        ' Co nghia la khong co du lieu nao
        MsgBox "Khong co du lieu nao de xuat." & vbCrLf & _
               "Xin kiem tra lai.", vbOKOnly + vbInformation, gcsAppName
        GoTo ErrorExit
    End If

    lCon = KetNoi
    If lCon = 1 Then
        gcnObj.Open
        arrFieldNames = Array("MaSo", "HoTen", _
                              "NgaySinh", "GioiTinh", _
                              "NgayNhap")             'Ban co the thay doi tuy theo so truong cua ban

        ' Tang toc
        SpeedOn
        ' Tao bien recordset
        Set oRs = CreateObject("ADODB.Recordset")
        oRs.CursorLocation = 3                        'adUseClient
        oRs.Open sTableName, gcnObj, 3, 4             'adOpenStatic, adLockBatchOptimistic
        arrValues = wsObj.Range("A2:E" & lLastRow)
        For i = 1 To UBound(arrValues, 1)
            If Len(arrValues(i, 1)) > 0 Then
                arrRecordvals = Array(arrValues(i, 1), arrValues(i, 2), _
                                      arrValues(i, 3), arrValues(i, 4), _
                                      arrValues(i, 5))
                oRs.AddNew arrFieldNames, arrRecordvals
                Application.StatusBar = "Ban dang nhap ban ghi " & i & "/" & (lLastRow - 1)
            End If
        Next i

        Application.StatusBar = "Dang cap nhat...Xin cho trong giay lat..."
        oRs.UpdateBatch
        MsgBox "Ban da xuat du lieu thanh cong.", vbOKOnly + vbInformation, gcsAppName

    Else
        MsgBox "Khong the ket noi voi CSDL." & vbCrLf & _
               "Xuat du lieu khong thanh cong.", vbOKOnly + vbInformation, gcsAppName
    End If

ErrorExit:

    ' Giai phong bien
    Set wsObj = Nothing
    Set oRs = Nothing
    SpeedOff
    If Not gcnObj Is Nothing Then
        If (gcnObj.State And adStateOpen) = adStateOpen Then
            gcnObj.Close
        End If
    End If
    Exit Sub

ErrorHandle:
    ' Xu ly loi tai day
    MsgBox "Co loi xay ra. Xin kiem tra lai.", vbOKOnly + vbInformation, gcsAppName
    Debug.Print Err.Number & ", " & Err.Description
    Resume ErrorExit

End Sub

Và thủ tục lấy dữ liệu từ Access đưa vào Excel:

Sub AccessToExcel()
    Dim lCon  As Long
    Dim sSQL  As String
    Dim adoCommand As Object                          'ADODB.Command
    Dim oRs   As Object                               'ADODB.Recordset
    Dim wsObj As Worksheet
    Dim lLastRow As Long


    Set wsObj = Application.ThisWorkbook.Worksheets("FilterFromAccess")
    lLastRow = FindLastRow(wsObj)
    lCon = KetNoi
    If lCon <> 1 Then
        MsgBox "Khong the ket noi voi CSDL." & vbCrLf & _
               "Xuat du lieu khong thanh cong.", vbOKOnly + vbInformation, gcsAppName
    Else
        ' Mo ket noi
        gcnObj.Open
        sSQL = "SELECT MaSo, HoTen, NgaySinh, GioiTinh, NgayNhap " & _
               "FROM TB_NhanVien " & _
               "WHERE MaSo='" & "HTN005" & "';"
        Set adoCommand = CreateObject("ADODB.Command")
        With adoCommand
            .CommandType = 1                          '1: adCmdText, 2: adCmdTable, 4: adCmdStoredProc
            .ActiveConnection = gcnObj
            .CommandText = sSQL
        End With
        Set oRs = CreateObject("ADODB.Recordset")
        oRs.Open adoCommand, , 3, 4
        If oRs.EOF Then
            MsgBox "Khong co record nao thoa dieu kien.", vbOKOnly + vbInformation, gcsAppName
        Else
            wsObj.Cells(lLastRow + 1, 1).CopyFromRecordset oRs
        End If

    End If

ErrorExit:
    Set adoCommand = Nothing
    Set oRs = Nothing
    Set wsObj = Nothing
    If Not gcnObj Is Nothing Then
        If (gcnObj.State And adStateOpen) = adStateOpen Then
            gcnObj.Close
        End If
    End If
    Exit Sub

ErrorHandle:
    ' Xu ly loi tai day
    MsgBox "Co loi xay ra. Xin kiem tra lai.", vbOKOnly + vbInformation, gcsAppName
    Debug.Print Err.Number & ", " & Err.Description
    Resume ErrorExit
End Sub

Lê Văn Duyệt

Anh ơi cho em hỏi là em tải file về rồi chạy nó báo lỗi không kết nối được.Là sao anh nhỉ.