Lấy giữ liệu từ sheet đang đóng bằng code Ado (2 người xem)

[lhthai]

Chào Các Anh
Hiện tại mình đang dùng code lấy giữ liệu trong bài sau:
http://www.giaiphapexcel.com/forum/showthread.php?75143-Bài-tập-về-ADO-căn-bản/page7
Nay muốn bổ sung thêm điều kiện khi gõ ngày cột B3 thì lộc giữ liệu những ngày mình cần.
Các anh chị xem file dinh kèm.

 

[Quang_Hải]

Nếu viết lắng nhằng thêm chút nữa thì thử cách này

Sub Main()
Dim Path As String, I As Long, j As Long, Fname(), shName()
Fname = Array("TH01.xls", "TH02.xls", "TH03.xls")
shName = Array("1-10", "11-20", "21-31")
For I = 0 To UBound(Fname)
   Path = ThisWorkbook.Path & "\" & Fname(I)
   For j = 0 To UBound(shName)
      Getdata Path, CStr(shName(j))
   Next
Next
End Sub

Sub Getdata(Path As String, datarange As String)
Dim cnn As Object, lrs As Object
Set cnn = CreateObject("ADODB.Connection")
cnn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & Path & " ;Extended Properties=""Excel 8.0;HDR=Yes;"";")
Set lrs = cnn.Execute("SELECT * FROM [" & datarange & "$] " & _
"WHERE CODE = '" & Sheet1.Range("B3") & "'")
Sheet1.Range("A65536").End(3)(2).CopyFromRecordset lrs
End Sub

 

[lhthai]

May mắn thì trúng, trật thì thôi vậy. ADO không phải dễ xơi đâu. Chưa am tường VBA mà chọc vào ADO coi chừng tẩu hoả và dữ liệu sai tè le cho coi.

Sub CopyAll()
Dim cnn As Object, lrs As Object
Dim Path As String, I As Long, j As Long, Fname(), shName()
Fname = Array("TH01.xls", "TH02.xls", "TH03.xls")
shName = Array("1-10", "11-20", "21-31")
Set cnn = CreateObject("ADODB.Connection")
For I = 0 To UBound(Fname)
   Path = ThisWorkbook.Path & "\" & Fname(I)
   For j = 0 To UBound(shName)
      cnn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;" & _
      "Data Source=" & Path & " ;Extended Properties=""Excel 8.0;HDR=Yes;"";")
      Set lrs = cnn.Execute("SELECT * FROM [" & shName(I) & "$] " & _
      "WHERE CODE = '" & Sheet1.Range("B3") & "'")
      Sheet1.Range("A65536").End(3)(2).CopyFromRecordset lrs
      cnn.Close
   Next
   Set lrs = Nothing
Next
Set cnn = Nothing
End Sub

Cám ơn Anh QuangHai rất nhiều.
Em muốn thử code Ado xem có lấy được nhiều file đang đóng không thôi
Em dùng code lấy 1 file thì thấy được rồi.Em để tên file ở cột A1 tìm từ từ cũng được còn code này của Anh thì kết quả không như mong muốn.

Dim cnn As Object, lrs As Object
Dim shName, I As Long, Fname
    Sheet1.Range("A6:H1000").ClearContents
    Fname = Sheet1.Range("A1")
    Set cnn = CreateObject("ADODB.Connection")
    shName = Array("1-10", "11-20", "21-31")
 '-----------------------------------------------------------------------------------
 'Tao ket noi CSDL


    cnn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;" & _
               "Data Source=" & ThisWorkbook.Path & "\" & Fname & _
               ";Extended Properties=""Excel 8.0;HDR=Yes;"";")


'-----------------------------------------------------------------------------------
For I = 0 To UBound(shName)
    Set lrs = cnn.Execute("SELECT * FROM [" & shName(I) & "$] " & _
                           "WHERE CODE = '" & Sheet1.Range("B3") & "'")
 '-----------------------------------------------------------------------------------
  'Copy ket qua vao sheet
    Sheet1.Range("A6500").End(xlUp)(2).CopyFromRecordset lrs
Next I
'-----------------------------------------------------------------------------------
lrs.Close: Set lrs = Nothing
cnn.Close: Set cnn = Nothing