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

tuhocvba

Administrator
Thành viên BQT
Điều kiện: Hãy khai báo thư viện:
Microsoft ActiveX Data Objects 2.X Library
Hoặc:
Microsoft ActiveX Data Objects 6.1 Library
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:
 
Sửa lần cuối:

Euler

Administrator
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
 

Thái Phúc

Yêu THVBA
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
Bác @Snow24 giúp em up file ví dụ của code này được không ạ. Em xin cảm ơn
 

linhlbk

Yêu THVBA
E code để lấy data bằng adodb nhưng toàn báo Provider cannot be found. it may be not properly installed. Em đã vào Tool chọn Reference đầy đủ.
Anh/chị xem giúp em có vấn đề gì ko. em cảm ơn
Mã:
Sub ado()

Dim Cn As New ADODB.Connection
Dim Rs As New Recordset
Dim c As Integer
Dim query As String
pro = "Provider=Microsoft.ace.oledb.12.0;Data Source=" & "C:\Users\linhlbk\Desktop\Raw Data.xlsx" & ";Extended Properties=""Excel 12.0;HDR=yes;"";"
Cn.Open pro
query = "Select * from [Page$]"
Rs.Open query, Cn, adOpenDynamic, adLockOptimistic
For c = o To Rs.Fields.Count - 1
         Cells(1, c + 1) = Rs.Fields(c).Name
Next

Cells(2, 1).CopyFromRecordset Rs
Set Cn = Nothing
Set Rs = Nothing
End Sub
 
D

Deleted member 1392

Guest
@linhlbk Bạn thử dùng hàm của tôi ở bài #4 xem, không ADO vẫn lấy dữ liệu file đang đóng bình thường.
 

linhlbk

Yêu THVBA
@Ngày Mới . Cách trên mình có thử thì chạy được rất Oke. Tuy nhiên mình muốn dùng ado để có thể lấy ở nhiều File 1 lúc để tốc độ nhanh hơn việc workbook.open từng File.
 
D

Deleted member 1392

Guest
@linhlbk Bạn nói tôi hơi khó hiểu. Tại #4, hàm của tôi không hề có thao tác Open như bạn nói. Dựa trên những dữ liệu tôi đã test, tốc độ trả về kết quả không hề thua kém ADO, thậm chí thao tác thì đơn giản hơn ADO rất nhiều.

Về việc lấy dữ liệu nhiều file, bạn chỉ cần thay đổi đường dẫn và vùng cần lấy dữ liệu trong hàm thì đã lấy được dữ liệu nhiều file rồi.
 
Sửa lần cuối bởi điều hành viên:

linhlbk

Yêu THVBA
@Ngày Mới hiện có 3 cách lấy data: 1 là dùng adodb (đang vướng) lỗi báo provider cannot be found, 2 là dùng hàm bạn viết chạy rất oke, 3 là loop workbook open từng file. Cách bạn viết ra chạy rất oke. Cách loop từng File cũng chạy được nhưng chậm nếu số lượng file cần lấy data nhiều nên muốn nghiêm cứu cái dùng ADO thêm.
 
D

Deleted member 1392

Guest
@linhlbk Sao phải khó vậy bạn. Nào sử dụng tốt thì dùng, quan trọng là kết quả không lỗi lầm gì là được rồi.
 

NhanSu

SMod
Thành viên BQT
@linhlbk mình chạy thử code thì thấy bình thường, như vậy có thể bản office của bạn bị lỗi. Bạn nên sử dụng yêu cầu bắt buộc khai báo biến (option exolicit) để tránh lỗi. Có cách nữa để lấy dữ liệu từ file đóng là sử dụng power query.
 

Tín97

Yêu THVBA
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 = Nothi
[CODE]Sub copfile()
Dim Chonfile As Variant
Dim i As Integer
Dim sh As String
Dim r As String
Dim dong As Integer
Dim cot As Integer
Set wb = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tmr As Double
On Error GoTo ErrorHandler
sh = InputBox("Tên sheet can copy", "Thông Báo!") ' "datadcs"
r = InputBox("Vung can copy", "Thông báo!") '"a1:aj19"
tmr = Timer()
dong = Range(r).Rows.Count
cot = Range(r).Columns.Count
Chonfile = Application.GetOpenFilename(Title:="Chon file", filefilter:="Excel file (*.xls*), *.xls*", MultiSelect:=True)
Sheets.Add After:=ActiveSheet
For i = 1 To UBound(Chonfile)
     Range(Cells(i, 1), Cells(i, 2)) = Chonfile(i)
     Range(Cells(1, 2), Cells(i, 2)).Replace what:="*\", Replacement:=""
     Cells(i, 3).FormulaR1C1 = _
        "=LEFT(RC[-2]:R[6]C[-2],LEN(RC[-2]:R[6]C[-2])-LEN(RC[-1]:R[6]C[-1]))&""[""&RC[-1]:R[6]C[-1]&""]"""
     Cells(i, 3) = Cells(i, 3).Value & sh & "'!" & r
     Range(Cells(i * dong - (dong - 1), 4), Cells(i * dong, cot + 3)).FormulaArray = "='" & Cells(i, 3)
     Range(Cells(i * dong - (dong - 1), 4), Cells(i * dong, cot + 3)) = Range(Cells(i * dong - (dong - 1), 4), Cells(i * dong, cot + 3)).Value
Next
Range("A:A,C:C").Delete
Range("A:A").EntireColumn.AutoFit
ActiveSheet.Name = UBound(Chonfile) & "lot_in_" & Left(Timer() - tmr, 3) & "s"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
ErrorHandler:
Application.Assistant.DoAlert "THÔNG BÁO", "Ch" & ChrW(432) & "a " & ChrW(273) & ChrW(7911) _
          & " " & ChrW(273) & "i" & ChrW(7873) & "u ki" & ChrW(7879) & "n " & ChrW( _
          273) & ChrW(7875) & " Copy", 0, 4, 0, 0, 0
Exit Sub
End Sub
ng
End Sub[/CODE]
Đâ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
Chào bạn, hình như bạn cũng đã từng giúp mình trong một bài viết rồi,
Hôm nay mò mẫm mãi mình cũng gõ được code với cùng ý tưởng như bạn
Code này sẽ tạo 1 sheet mới, dùng công thức như bạn nói, mình sẽ khai báo tên sheet và vùng dữ liệu cần lấy bằng Inputbox, và Multi file.
Mục đích mình viết code này là để áp dụng ở mọi file Excel, mọi đường dẫn, có độ tùy biến cao, thậm chí mình đã dùng addin để đưa nó lên Ribbon. Nhờ sự giúp đỡ của bạn trong bào viết trước nên giờ code mình chạy cũng khá ổn. Nhưng vẫn mong bạn và mọi người giành 1 ít thời gian để xem tối ưu thêm code của mình, xin cảm ơn.
Đây:
Sub copfile()
Dim Chonfile As Variant
Dim i As Integer
Dim sh As String
Dim r As String
Dim dong As Integer
Dim cot As Integer
Set wb = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tmr As Double
On Error GoTo ErrorHandler
sh = InputBox("Tên sheet can copy", "Thông Báo!") ' "datadcs"
r = InputBox("Vung can copy", "Thông báo!") '"a1:aj19"
tmr = Timer()
dong = Range(r).Rows.Count
cot = Range(r).Columns.Count
Chonfile = Application.GetOpenFilename(Title:="Chon file", filefilter:="Excel file (*.xls*), *.xls*", MultiSelect:=True)
Sheets.Add After:=ActiveSheet
For i = 1 To UBound(Chonfile)
     Range(Cells(i, 1), Cells(i, 2)) = Chonfile(i)
     Range(Cells(1, 2), Cells(i, 2)).Replace what:="*\", Replacement:=""
     Cells(i, 3).FormulaR1C1 = _
        "=LEFT(RC[-2]:R[6]C[-2],LEN(RC[-2]:R[6]C[-2])-LEN(RC[-1]:R[6]C[-1]))&""[""&RC[-1]:R[6]C[-1]&""]"""
     Cells(i, 3) = Cells(i, 3).Value & sh & "'!" & r
     Range(Cells(i * dong - (dong - 1), 4), Cells(i * dong, cot + 3)).FormulaArray = "='" & Cells(i, 3)
     Range(Cells(i * dong - (dong - 1), 4), Cells(i * dong, cot + 3)) = Range(Cells(i * dong - (dong - 1), 4), Cells(i * dong, cot + 3)).Value
Next
Range("A:A,C:C").Delete
Range("A:A").EntireColumn.AutoFit
ActiveSheet.Name = UBound(Chonfile) & "lot_in_" & Left(Timer() - tmr, 3) & "s"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
ErrorHandler:
Application.Assistant.DoAlert "THÔNG BÁO", "Ch" & ChrW(432) & "a " & ChrW(273) & ChrW(7911) _
          & " " & ChrW(273) & "i" & ChrW(7873) & "u ki" & ChrW(7879) & "n " & ChrW( _
          273) & ChrW(7875) & " Copy", 0, 4, 0, 0, 0
Exit Sub
End Sub
 
D

Deleted member 1392

Guest
@Lương Tuấn Ba Bạn cần nói rõ ràng hơn để giúp người khác đọc vào hiểu bạn đang nói gì.
1. Đối tượng bạn cần xoá là gì (Range, file...), và dùng phương thức xoá như thế nào?
2. quyery là cái gì ?
3. Cần mô tả, minh hoạ bằng hình ảnh những gì bạn đang nói.
 
Top