ADO-kết nối để lấy dữ liệu từ file excel đang đóng

tuhocvba

Administrator
Thành viên BQT
Nói là không cần mở file có lẽ là không đúng, nó vẫn cần mở file nhưng không phải là Workbooks.Open như chúng ta đã biết, nó kết nối với excel (hoặc csv) và lấy thông tin rất nhanh chóng, tốc độ hơn hẳn so với phương thức .
Bài viết này tôi sẽ đưa ra một ví dụ về một chương trình mẫu, lấy dữ liệu từ một file csv đang đóng.
Chú ý rằng nếu file csv đang mở thì sẽ không lấy được dữ liệu, lập tức sẽ ra thông báo lỗi như sau:
Bạn cần đăng nhập để thấy hình ảnh


Ta hãy xem xét chương trình dưới đây sẽ thực hiện việc lấy dữ liệu từ một file csv cho vào file excel hiện hành chứa macro.
Mã:
Sub OpenDataBase()
On Error GoTo PROC_ERR
    Dim cn          As New ADODB.Connection
    Dim Rs          As New ADODB.Recordset
    Dim sEXTENDED   As String
    Dim sSrcDir     As String   ' Kết nối tới folder
    Dim sSql        As String   ' SQL
    Dim oWs         As Worksheet
    Dim lCnt        As Long     ' Số cột dữ liệu
    
    sSrcDir = "C:\Users\jpnfriend.net\Desktop\VBA\New folder (4)\Hoi_GPE\"
    
    ' Thiết định Provider
    cn.Provider = "Microsoft.ACE.OLEDB.12.0"    ' Giống như access, từ Office 2007 thì đây là thông số Provider được dùng

    ' Đường dẫn thư mục chứa file mà ta muốn đọc
    cn.Properties("Data Source") = sSrcDir
    
    ' Thiết định các thuộc tính khác
    sEXTENDED = "text"
    sEXTENDED = sEXTENDED & ";FMT=Delimited"
    sEXTENDED = sEXTENDED & ";HDR=Yes"
    cn.Properties("Extended Properties").Value = sEXTENDED
    
    ' Bắt đầu kết nối
    cn.Open
    
    sSql = "SELECT * FROM [database.csv]"
    
    ' Thực thi SQL
    Rs.Open sSql, cn
    
    If Rs.EOF Then
        ' Nếu kết quả không có gì thì kết thúc chương trình
        GoTo PROC_EXIT
    End If
    
    Set oWs = ThisWorkbook.Sheets("Sheet1")
    
    ' Hiển thị  tên trường (tên cột) dữ liệu lấy được
    For lCnt = 1 To Rs.Fields.Count
        oWs.Cells(1, lCnt).Value = "'" & Rs.Fields(lCnt - 1).Name
    Next
    
    ' Kết quả lấy được cho hiển thị trên file excel hiện hành
    oWs.Cells(2, 1).CopyFromRecordset Rs
    
    Rs.Close
    
    cn.Close
    
PROC_EXIT:
    On Error Resume Next
    
    ' Xóa sạch các biến để làm sạch bộ nhớ
    Set Rs = Nothing
    Set cn = Nothing
    
    Exit Sub
PROC_ERR:
    MsgBox "Ket noi ADO(CSV/TEXT) co loi xay ra:" & Err.Description & "(" & Err.Number & ")" & vbCrLf & sSrcDir, vbCritical
    GoTo PROC_EXIT
End Sub
Bạn cần đăng nhập để thấy hình ảnh

Thuyết minh thêm về chương trình trên:
Mã:
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
Thuộc tính này tùy thuộc vào phiên bản Office mà có sự khác nhau. Cụ thể với các phiên bản excel từ trước 2007 trở về trước thì là:
Mã:
"Microsoft.Jet.OLEDB.4.0"
Các thuộc tính khác:
Mã:
sEXTENDED = "text"
sEXTENDED = sEXTENDED & ";FMT=Delimited"
sEXTENDED = sEXTENDED & ";HDR=Yes"

cn.Properties("Extended Properties").Value = sEXTENDED
Khi có nhiều thuộc tính thì chúng được phân cách bởi dấu chấm phẩy ;
"text" biểu thị rằng đây là một file text
"FMT=Delimited" : Phân biệt định dạng file. CSV được chỉ định là Delimited.
"HDR=Yes": Coi dòng đầu tiên như dòng tiêu đề Header. Nếu để là No, sẽ coi dòng đầu tiên như là data.
Thử thay đổi thông số và so sánh:
Bạn cần đăng nhập để thấy hình ảnh

Chả hiểu sao khi để No, dòng tiêu đề kỳ quặc F1, F2,... hiện ra. Để Yes thì dữ liệu được bảo toàn.

"Extended Properties" Bằng cách thiết định giá trị thuộc tính này mà thiết định kết nối được thành lập. Hãy cẩn thận với giá trị này.
Mình thử bỏ dòng code này đi, là hết kết nối lấy dữ liệu luôn. Báo lỗi luôn này.
Bạn cần đăng nhập để thấy hình ảnh

Đọc bản ghi:
Mã:
recordset.Open Source, ActiveConnection, CursorType, LockType, Options
  • Source: Thực thi
  • ActiceConnection: Chỉ định kết nối
  • (CursotType): Mở RecordSet và chỉ định con trỏ. Có thể chỉ định giá trị cho
  • (LockType): Khi mở RecordSet thì chỉ định khóa (cấm người khác truy cập nếu file để trong mạng Lan). Có thể chỉ định giá trị cho
  • (Options): Các thiết định khác

Nếu như chỉ đọc dữ liệu thì có lẽ chỉ cần hai tham số sau là đủ SourceとActiveConnection.
Mã:
For lCnt = 1 To Rs.Fields.Count
    oWs.Cells(1, lCnt).Value = "'" & Rs.Fields(lCnt - 1).Name
Next
Lấy thông tin tên cột (trường dữ liệu) Field.
Mã:
RecordSet.EOF
Không còn dòng dữ liệu nào tiếp theo. Ý nói đã kết thúc dữ liệu.
Mã:
'Rs(j - 1).Value
RecordSet(index).Value
Giá trị lấy được.
Mã:
RecordSet.MoveNext
Di chuyển con trỏ sang dòng tiếp theo.
Provider là gì?
Microfost.ACE.OLEDB.12.0 hay Microsoft.Jet.OLEDB.4.0 là các qui tắc để kết nối cơ sở dữ liệu.
OLE DB(Object Linking and Embedding DataBase)Provider là API cung cấp tính năng truy cập vào cơ sở dữ liệu như , < >
Bài viết được dịch từ:
Các bài viết tham khảo khác:
 

Euler

Mod
Thành viên BQT
Update file excel đang đóng bằng kết nối ADO. Bài viết này có lẽ là để đáp ứng nguyện vọng của bạn @Snow24 .
Tôi mong bạn từ sau hãy bớt chút thời gian trình bày cho rõ mình muốn gì. Những người trả lời cũng phải viết, gõ và biên soạn hình ảnh, và upload file. Vậy tại sao người hỏi lại không làm được điều đó.
Tôi đi thẳng vào code:
Mã:
Sub update_excel()

Dim cnn         As ADODB.Connection
Dim objMyCmd    As ADODB.Command
Dim strQuery    As String


Set cnn = New ADODB.Connection
Set objMyCmd = New ADODB.Command

constConfigFile = "\Output_190719233049.xls" 'File cần update nằm chung thư mục với file macro.

With cnn

    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & ActiveWorkbook.Path & constConfigFile & ";" & _
    "Extended Properties=""Excel 8.0;HDR=Yes;"";"
    .Open

End With

strQuery = "update [Sheet1$] Set [test]='Hello' WHERE [test]='tuhocvba'"
'File cần update có sheet tên là Sheet1, có cột tên là test được thể hiện như ảnh minh họa ở dưới.
objMyCmd.CommandType = adCmdText
objMyCmd.CommandText = strQuery
objMyCmd.ActiveConnection = cnn

objMyCmd.Execute


Set objMyCmd = Nothing
Set cnn = Nothing


End Sub
Cụ thể file cần update có hình thù như sau:
Bạn cần đăng nhập để thấy hình ảnh

Chú ý thiết định ADO cho VBA:
Bạn cần đăng nhập để thấy hình ảnh

Kết quả chạy code:
Bạn cần đăng nhập để thấy hình ảnh
 
S

Snow24

Guest
@Snow24 có thấy là bạn có thể trình bày cho dễ hiểu hơn không ạ?
Điều người ta quan tâm theo trình tự như sau (bạn thử đặt vào vị trí của người đọc)
Trạng thái: Đã khắc phục lỗi/ Chưa khắc phục lỗi
Nội dung: sql sai
Cụ thể:
Before (trạng thái sai)
After (trạng thái không còn sai)

Người đọc quan tâm theo trình tự các mục từ trên xuống ạ.
Mình cũng không nhìn thấy SET ở đâu nữa.
Cảm ơn mọi người đã quan tâm nhé.Code mình chỉnh lại và đã chạy được.Sai chút ít ở câu lệnh SQL.
Trạng thái: Đã khắc phục lỗi
Nội dung: sql sai
Cụ thể:
Before (trạng thái sai):

Mã:
 sql = "update [Sheet1$D5:D6] F1='" & arr(i, 1) & "'"
After (trạng thái không còn sai) :
Mã:
 sql = "update [Sheet1$D5:D6] set [F1]='" & arr(i, 1) & "'"
Mã:
Sub chuyendulieu()
    Dim arr, i As Long, lr As Long, duonglinh As String, ten As String, wb As Workbook
    Dim sql As String, cnn As Object, objMyCmd As Object, a
    Set cnn = CreateObject("adodb.connection")
    Set objMyCmd = CreateObject("adodb.command")
    SpeedOn
    On Error GoTo loi
With Sheets("DO")
     lr = .Range("D" & Rows.Count).End(xlUp).Row
     arr = .Range("b1:D" & lr).Value
     duonglinh = ThisWorkbook.Path
     For i = 1 To UBound(arr)
         ten = "\MP\" & arr(i, 3) & ".xlsm"
         With cnn
             .Provider = "Microsoft.ACE.OLEDB.12.0"
             .ConnectionString = "Data Source=" & duonglinh & ten & ";" & _
             "Extended Properties=""Excel 8.0;HDR=No;"";"
             .Open
        End With
     sql = "update [Sheet1$D5:D6] set [F1]='" & arr(i, 1) & "'"
     objMyCmd.CommandType = adCmdText
     objMyCmd.CommandText = sql
     objMyCmd.ActiveConnection = cnn
     objMyCmd.Execute
     cnn.Close
     Next i
End With
MsgBox "daxong"
SpeedOff
Exit Sub
loi:

   SpeedOff
   MsgBox "da xay ra loi o trong file " & arr(i, 3)
End Sub
 

Ngày Mới

Thành viên
Tình cờ lướt qua nên tôi cũng xin đóng góp chút kiến thức ít ỏi của mình.

Thực ra lấy file đang đóng vẫn còn một cách khác mà không cần dùng đến ADO. Cách này đơn giản hơn, chúng ta có thể tận dụng luôn công thức có sẵn của Excel.
Cấu trúc công thức đó như sau:
Mã:
='<Địa chỉ thư mục chứa file> [ <Tên file> ] <Tên Sheet>'! <Vùng dữ liệu>
Xin lưu ý: đây là công thức mảng nên ta cần Ctrl + Shift + Enter
Ví dụ: Ta cần lấy một file có đường dẫn "C:\Users\IPC\Desktop\Test.xlsx", Sheet tên "Sheet1", Vùng "A1: A20", và dùng ta cần nạp dữ liệu là Sheet hiện hành có vùng "B1:E20". Ta sẽ tô chọn vùng "B1:E20" và nhập công thức:
Mã:
='C:\Users\IPC\Desktop\[Test.xlsx]Sheet1'!A1:A20
Nhấn Ctrl + Shift + Enter, Ta có ngay kết quả
Bạn cần đăng nhập để thấy hình ảnh


Để dễ dàng cho mọi người sử dụng, Tôi làm sẵn một Function. Cấu trúc Function như sau
Mã:
'//AUTHOR: NGAY MOI
'//FUNCTION: LAY DU LIEU FILE DANG DONG
'//TYPE:
'/RngIn: Vung can nap du lieu Output
'/strPath: Duong dan den file Input
'/strSheet: Ten Sheet file Input
'/strRng: Vung du lieu file Input

Sub GetRng(RngIn As Range, ByVal strPath As String, ByVal strSheet As String, ByVal strRng As String)
Dim strPathArr As String
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")

'//LAP CONG THUC LAY DU LIEU TU FILE DANG DONG
strPathArr = "'" & FSO.GetFile(strPath).ParentFolder & "\[" & FSO.GetFile(strPath).Name & "]" & strSheet & "'!" & strRng

'//NAP CONG THUC
With RngIn.Resize(Range(strRng).Rows.Count, Range(strRng).Columns.Count)
    .FormulaArray = "=" & strPathArr

    'XOA BO CONG THUC
    .Value = .Value
End With
Set FSO = Nothing
End Sub
Đây là thủ tục gọi thay thế cho ví dụ phía trên
Mã:
Sub GetArrFile()
Call GetRng(Thisworkbook.Activesheet.Range("B1"), "C:\Users\IPC\Desktop\Test.xlsx", "Sheet1", "A1:D20")
End Sub
 
Sửa lần cuối:

linhlbk

Thành viên mới
Cho e hỏi, dùng ado để lấy data trong file excel như trên hình như dữ liệu phải bắt đầu từ a1, vậy với những file data bắt đầu từ b5 chẳng hạn thì xử lý như nào?
 

USA_Covid19

Thành viên tích cực
@linhlbk bạn sữa ở dòng này
Mã:
Sub GetArrFile()
Call GetRng(Thisworkbook.Activesheet.Range("B1"), "C:\Users\IPC\Desktop\Test.xlsx", "Sheet1", "A1:D20")
End Sub
 

Bao Quoc

Thành viên mới
Mọi người cho mình hỏi.
Mình cũng dùng ADO để lấy dữ liệu từ file đang đóng copy vào sheet mới. Nhưng dữ liệu nhận được không đầy đủ. Có những file chạy rất ok, nhưng có những file bị thiếu dữ liệu ( bị mất dữ liệu ở 1 vài ô).

Mã:
Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)
            
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
 
  If lVer < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
 
  szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  'MsgBox (tmpArr(8, 1))
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function
 
Top