Đố vui về ADO, DAO. (1 người xem)

VetMini · 12/7/13

"FROM [Data$] where trim(Partition([id],1,100,10)) in ('1: 10','91:100')"

Tôi tưởng là cái chỗ đó phải do code tính ra chứ không được gõ vào. Đoạn code tính ra chỗ này chạy chậm quá (mất hơn một phút cho một CSDL 10000 dòng - thử trên SQL Server, chứ Access có thể còn chậm hơn) cho nên tôi chịu thua.

Hai Lúa Miền Tây · 12/7/13

Câu hỏi mấy lần trước tuy không khó nhưng có rất ít người tham gia, thôi thì lần này dể hơn.

Ví dụ tôi có 3 WB: Data1.xls, Data2.xls, KetQua.xls có cùng 1 thư mục.

Trong Data1.xls và Data2.xls đều có 1 sheet là Sheet2, vùng dữ liệu là A1:E20, có cấu trúc giống nhau.
Trong KetQua.xls có 2 sheet: Sheet2 vùng dữ liệu là A1:E20, có cấu trúc giống nhau với 2 WB trên, và 1 sheet còn lại là KetQua dùng để chứa kết quả khi chạy code.

Xin hỏi: Là tại WB KetQua.xls chạy code như thế nào mà không dùng vòng lặp để gộp dữ liệu Sheet2 của 3 WB trên với điều kiện cột STT là không trống?

dhn46 · 12/7/13

Hai Lúa Miền Tây đã viết:
Câu hỏi mấy lần trước tuy không khó nhưng có rất ít người tham gia, thôi thì lần này dể hơn.

Ví dụ tôi có 3 WB: Data1.xls, Data2.xls, KetQua.xls có cùng 1 thư mục.

Trong Data1.xls và Data2.xls đều có 1 sheet là Sheet2, vùng dữ liệu là A1:E20, có cấu trúc giống nhau.

Trong KetQua.xls có 2 sheet: Sheet2 vùng dữ liệu là A1:E20, có cấu trúc giống nhau với 2 WB trên, và 1 sheet còn lại là KetQua dùng để chứa kết quả khi chạy code.

Xin hỏi: Là tại WB KetQua.xls chạy code như thế nào mà không dùng vòng lặp để gộp dữ liệu Sheet2 của 3 WB trên với điều kiện cột STT là không trống?

Em xin đưa ra giải pháp đầu tiên

Mã:

Sub Tonghop()
Dim lsSQL As String, Cnn As Object, lrs As Object
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
FileFullName = Application.ThisWorkbook.FullName
With Cnn
   If Val(Application.Version) < 12 Then
      .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileFullName & ";Extended Properties=""Excel 8.0;HDR=Yes"";"
   Else
      .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileFullName & ";Extended Properties=""Excel 12.0;HDR=Yes"";"
   End If
   .Open
End With

lsSQL = "Select a.* From [Excel 8.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path & "\Data1.xls].[Sheet2$A1:E20] a " _
        & "Where a.Stt Is Not Null " _
        & "Union all " _
        & "Select b.* From [Excel 8.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path & "\Data2.xls].[Sheet2$A1:E20] b " _
        & "Where b.Stt Is Not Null " _
        & "Union all " _
        & "Select c.* From [sheet2$A1:E20] c " _
        & "Where c.Stt Is Not Null"
        
lrs.Open lsSQL, Cnn, 3, 1
Range("A2").CopyFromRecordset lrs
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
Exit Sub
Handle:
MsgBox Err.Description
Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
End Sub

Hai Lúa Miền Tây · 12/7/13

dhn46 đã viết:

Em xin đưa ra giải pháp đầu tiên

Mã:

Sub Tonghop()
Dim lsSQL As String, Cnn As Object, lrs As Object
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
FileFullName = Application.ThisWorkbook.FullName
With Cnn
   If Val(Application.Version) < 12 Then
      .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileFullName & ";Extended Properties=""Excel 8.0;HDR=Yes"";"
   Else
      .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileFullName & ";Extended Properties=""Excel 12.0;HDR=Yes"";"
   End If
   .Open
End With

lsSQL = "Select a.* From [Excel 8.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path & "\Data1.xls].[Sheet2$A1:E20] a " _
        & "Where a.Stt Is Not Null " _
        & "Union all " _
        & "Select b.* From [Excel 8.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path & "\Data2.xls].[Sheet2$A1:E20] b " _
        & "Where b.Stt Is Not Null " _
        & "Union all " _
        & "Select c.* From [sheet2$A1:E20] c " _
        & "Where c.Stt Is Not Null"
        
lrs.Open lsSQL, Cnn, 3, 1
Range("A2").CopyFromRecordset lrs
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
Exit Sub
Handle:
MsgBox Err.Description
Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
End Sub

Rất nhanh, nhưng cần rút gọn lại nữa. Code có xử lý file 2003 và 2007 nhưng ở câu lệnh truy vấn vẫn để 2003.

dhn46 · 12/7/13

Hai Lúa Miền Tây đã viết:
Rất nhanh, nhưng cần rút gọn lại nữa. Code có xử lý file 2003 và 2007 nhưng ở câu lệnh truy vấn vẫn để 2003.

Vâng anh HLMT, tới thời điểm này em cũng chưa thuộc hết các phần trong sub, chủ yếu là Copy Paste rồi chỉnh sửa. Anh có bí quyết gì để học các cấu trúc nhanh hơn không, bật mí cho em với?

Mã:

 Sub Tonghop()
Dim lsSQL As String, Cnn As Object, lrs As Object, Ver As String
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
FileFullName = Application.ThisWorkbook.FullName
With Cnn
   If Val(Application.Version) < 12 Then
      .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileFullName & ";Extended Properties=""Excel 8.0;HDR=Yes"";"
      Ver = "[Excel 8.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path
   Else
      .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileFullName & ";Extended Properties=""Excel 12.0;HDR=Yes"";"
      Ver = "[Excel 12.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path
   End If
   .Open
End With
lsSQL = "Select a.* From " & Ver & "\Data1.xls].[Sheet2$A1:E20] a " _
        & "Where a.Stt Is Not Null " _
        & "Union all " _
        & "Select b.* From " & Ver & "\Data2.xls].[Sheet2$A1:E20] b " _
        & "Where b.Stt Is Not Null " _
        & "Union all " _
        & "Select c.* From [sheet2$A1:E20] c " _
        & "Where c.Stt Is Not Null"
lrs.Open lsSQL, Cnn, 3, 1
Range("A2").CopyFromRecordset lrs
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
Exit Sub
Handle:
MsgBox Err.Description
Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
End Sub

Hai Lúa Miền Tây · 12/7/13

dhn46 đã viết:

Vâng anh HLMT, tới thời điểm này em cũng chưa thuộc hết các phần trong sub, chủ yếu là Copy Paste rồi chỉnh sửa. Anh có bí quyết gì để học các cấu trúc nhanh hơn không, bật mí cho em với?

Mã:

 Sub Tonghop()
Dim lsSQL As String, Cnn As Object, lrs As Object, Ver As String
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
FileFullName = Application.ThisWorkbook.FullName
With Cnn
   If Val(Application.Version) < 12 Then
      .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileFullName & ";Extended Properties=""Excel 8.0;HDR=Yes"";"
      Ver = "[Excel 8.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path
   Else
      .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileFullName & ";Extended Properties=""Excel 12.0;HDR=Yes"";"
      Ver = "[Excel 12.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path
   End If
   .Open
End With
lsSQL = "Select a.* From " & Ver & "\Data1.xls].[Sheet2$A1:E20] a " _
        & "Where a.Stt Is Not Null " _
        & "Union all " _
        & "Select b.* From " & Ver & "\Data2.xls].[Sheet2$A1:E20] b " _
        & "Where b.Stt Is Not Null " _
        & "Union all " _
        & "Select c.* From [sheet2$A1:E20] c " _
        & "Where c.Stt Is Not Null"
lrs.Open lsSQL, Cnn, 3, 1
Range("A2").CopyFromRecordset lrs
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
Exit Sub
Handle:
MsgBox Err.Description
Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
End Sub

- Để nhớ cấu trúc của nó thì mình không có bí quyết gì hết, chỉ đơn thuần là viết nhiều, áp dụng nhiều là nhớ.
- Câu lệnh truy vấn ở trên có thể rút gọn lại nữa đó bạn, cố lên nhé.
- Với lại code của bạn không có phần bắt lỗi nhưng ở bên dưới có kết quả bắt lỗi, nên dư mà thiếu:

Mã:

Exit Sub 
Handle: 
MsgBox Err.Description 
Set lrs = Nothing 
Cnn.Close: Set Cnn = Nothing

dhn46 · 12/7/13

Hai Lúa Miền Tây đã viết:
- Để nhớ cấu trúc của nó thì mình không có bí quyết gì hết, chỉ đơn thuần là viết nhiều, áp dụng nhiều là nhớ.
- Câu lệnh truy vấn ở trên có thể rút gọn lại nữa đó bạn, cố lên nhé.
- Với lại code của bạn không có phần bắt lỗi nhưng ở bên dưới có kết quả bắt lỗi, nên dư mà thiếu:

Mã:

Exit Sub Handle: MsgBox Err.Description Set lrs = Nothing Cnn.Close: Set Cnn = Nothing

Dạ vâng. Em thiếu phần

Mã:

On Error Go to Handle

Anh HLMT nếu rút gọn phần truy vấn thì em bỏ hết a, b, c đi thì còn rút được nữa không anh?

Hai Lúa Miền Tây · 12/7/13

dhn46 đã viết:
Dạ vâng. Em thiếu phần

Mã:

On Error Go to Handle

Anh HLMT nếu rút gọn phần truy vấn thì em bỏ hết a, b, c đi thì còn rút được nữa không anh?

Ngoài a, b, c ra vẫn còn chổ để rút gọn đó bạn.

dhn46 · 12/7/13

Hai Lúa Miền Tây đã viết:
Ngoài a, b, c ra vẫn còn chổ để rút gọn đó bạn.

Vậy em sửa như sau có rút được nữa không anh?

Mã:

lsSQL = "Select a.* from " _
        & "(Select * From " & Ver & "\Data1.xls].[Sheet2$A1:E20] " _
        & "Union all " _
        & "Select * From " & Ver & "\Data2.xls].[Sheet2$A1:E20] " _
        & "Union all " _
        & "Select * From [sheet2$A1:E20]) a " _
        & "Where a.STT Is Not Null"

Hai Lúa Miền Tây · 12/7/13

dhn46 đã viết:
Vậy em sửa như sau có rút được nữa không anh?

Mã:

lsSQL = "Select a.* from " _ & "(Select * From " & Ver & "\Data1.xls].[Sheet2$A1:E20] " _ & "Union all " _ & "Select * From " & Ver & "\Data2.xls].[Sheet2$A1:E20] " _ & "Union all " _ & "Select * From [sheet2$A1:E20]) a " _ & "Where a.STT Is Not Null"

Có thể rút ngắn lại biến Ver.

VetMini · 12/7/13

Thử nghiên cứu cách này, không dùng CopyRecordset:
Nếu sheet1 có sẵn dữ liệu thì dùng "INSERT INTO... SELECT * FROM ..."
Nếu sheet1 không có săn dữ liệu thì dùng "SELECT * INTO ... FROM ..."

Đố tiếp: nếu tôi dùng vòng lặp thì như thế nào?
Gợi ý: code có thể dùng cho N sheets.

Hai Lúa Miền Tây · 12/7/13

VetMini đã viết:
Thử nghiên cứu cách này, không dùng CopyRecordset:
Nếu sheet1 có sẵn dữ liệu thì dùng "INSERT INTO... SELECT * FROM ..."
Nếu sheet1 không có săn dữ liệu thì dùng "SELECT * INTO ... FROM ..."

Đố tiếp: nếu tôi dùng vòng lặp thì như thế nào?
Gợi ý: code có thể dùng cho N sheets.

Với dữ liệu câu đố ở bài 102 thì mình đưa tên file vào 1 array, duyệt qua từng tên file ở array rồi đưa dữ liệu vào.

Hai Lúa Miền Tây · 12/7/13

dhn46 đã viết:
Vậy em sửa như sau có rút được nữa không anh?

Mã:

lsSQL = "Select a.* from " _ & "(Select * From " & Ver & "\Data1.xls].[Sheet2$A1:E20] " _ & "Union all " _ & "Select * From " & Ver & "\Data2.xls].[Sheet2$A1:E20] " _ & "Union all " _ & "Select * From [sheet2$A1:E20]) a " _ & "Where a.STT Is Not Null"

Chỉnh cái sau

Mã:

Ver = "[Excel 8.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path

Thành

Mã:

strPath= ThisWorkbook.Path

Như vậy phần bẫy lỗi cũng không cần thêm 2 dòng này... Bạn test thử nhé.

dhn46 · 12/7/13

Hai Lúa Miền Tây đã viết:
Chỉnh cái sau

Mã:

Ver = "[Excel 8.0;HDR=Yes;IMEX=2;DATABASE=" & ThisWorkbook.Path

Thành

Mã:

strPath= ThisWorkbook.Path

Như vậy phần bẫy lỗi cũng không cần thêm 2 dòng này... Bạn test thử nhé.

Anh HLMT, em đã chỉnh sửa như trên sao file vẫn lỗi, anh kiểm tra giúp em nhé

Hai Lúa Miền Tây · 13/7/13

dhn46 đã viết:
Anh HLMT, em đã chỉnh sửa như trên sao file vẫn lỗi, anh kiểm tra giúp em nhé

Không chạy là do bạn thiếu dấu [

Mã:

lsSQL = "Select a.* from " _
        & "(Select * From [B][COLOR=#ff0000][[/COLOR][/B]" & strPath & "\Data1.xls].[Sheet2$A1:E20] " _
        & "Union all " _
        & "Select * From [B][COLOR=#ff0000][[/COLOR][/B]" & strPath & "\Data2.xls].[Sheet2$A1:E20] " _
        & "Union all " _
        & "Select * From [sheet2$A1:E20]) a " _
        & "Where a.STT Is Not Null"

Hai Lúa Miền Tây · 13/7/13

Đánh số TT

Tôi có bảng dữ liệu ở sheet1 (STT, Ten, SL, TenWB, TenSheet), do số thứ tự của sheet1 không đồng nhất nên phải đáng STT lại.
Vậy xin hỏi là câu lệnh truy vấn như thế nào sẽ cho ra cột STT đánh theo nhóm (Dựa vào cột TenWB). Kết quả ra ở Sheet2.
Xin cảm ơn.

VetMini · 13/7/13

VetMini đã viết:
...
Đố tiếp: nếu tôi dùng vòng lặp thì như thế nào?
Gợi ý: code có thể dùng cho N sheets.

Xi lỗi tôi lầm rồi. Xin các bạn bỏ qua câu này.
Lúc có ý kiến trên, tôi dự tính dùng chuỗi SQL nhiều lệnh để lấy dữ liệu vào multi-recordsets. Nhưng lúc thực hiện thì khám phá ra là loại CSDL thẳng hàng như Excel không cho phép làm như thế (SQL Server thì được, có lẽ Access cũng được)

Hai Lúa Miền Tây · 13/7/13

VetMini đã viết:
Xi lỗi tôi lầm rồi. Xin các bạn bỏ qua câu này.
Lúc có ý kiến trên, tôi dự tính dùng chuỗi SQL nhiều lệnh để lấy dữ liệu vào multi-recordsets. Nhưng lúc thực hiện thì khám phá ra là loại CSDL thẳng hàng như Excel không cho phép làm như thế (SQL Server thì được, có lẽ Access cũng được)

Chèn vẫn được nguyên bảng nhưng nó không hổ trợ cho điều kiện lọc để chèn.

[GPECODE=sql]Sub CopyDL()
Dim cnn As Object, lsSQL As String, lrs As Object, strPath As String, arr As Variant, i As Integer
Set cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
strPath = ThisWorkbook.Path
arr = Array("Data1", "Data2", "KetQua")
With cnn
.ConnectionString = "Provider= Microsoft.Jet.OLEDB.4.0; data source=" & strPath & _
"\KetQua.xls;Extended Properties=Excel 8.0;"
.Open
End With
For i = LBound(arr) To UBound(arr)
lsSQL = "INSERT INTO [KetQua$] select * FROM [" & strPath & "\" & arr(i) & "].[Sheet2$]"
lrs.Open lsSQL, cnn
Next
Set rs = Nothing: cnn.Close: Set cnn = Nothing: Erase arr

End Sub

[/GPECODE]

dhn46 · 15/7/13

Hai Lúa Miền Tây đã viết:
Tôi có bảng dữ liệu ở sheet1 (STT, Ten, SL, TenWB, TenSheet), do số thứ tự của sheet1 không đồng nhất nên phải đáng STT lại.
Vậy xin hỏi là câu lệnh truy vấn như thế nào sẽ cho ra cột STT đánh theo nhóm (Dựa vào cột TenWB). Kết quả ra ở Sheet2.
Xin cảm ơn.

Em lại mạnh dạn đưa ra phương án đầu tiên, anh xem và góp ý nhé

Mã:

Sub STT_Dhn46()
    Set adoConn = CreateObject("ADODB.Connection")
    Set adoRS = CreateObject("ADODB.Recordset")
    With adoConn
        .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & ThisWorkbook.FullName & _
                            ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
        .Open
    End With
    With adoRS
        .ActiveConnection = adoConn
        .Open "Select (Select Count(*)+1 from [sheet1$B1:E35] a Where a.TenWb = [sheet1$B1:E35].TenWb And a.Ten<[sheet1$B1:E35].Ten) As STT, " _
             & "Ten, SL, TenWb, TenSheet From [sheet1$B1:E35]" _
             & "Group by Ten, SL,TenWb, TenSheet " _
             & "Order by TenWb"
    End With
    With Sheet2
        .[A2:E100].ClearContents
        .[A2].CopyFromRecordset adoRS
    End With
    adoRS.Close: Set adoRS = Nothing
    adoConn.Close: Set adoConn = Nothing


End Sub

Hai Lúa Miền Tây · 16/7/13

dhn46 đã viết:

Em lại mạnh dạn đưa ra phương án đầu tiên, anh xem và góp ý nhé

Mã:

Sub STT_Dhn46()
    Set adoConn = CreateObject("ADODB.Connection")
    Set adoRS = CreateObject("ADODB.Recordset")
    With adoConn
        .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & ThisWorkbook.FullName & _
                            ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
        .Open
    End With
    With adoRS
        .ActiveConnection = adoConn
        .Open "Select (Select Count(*)+1 from [sheet1$B1:E35] a Where a.TenWb = [sheet1$B1:E35].TenWb And a.Ten<[sheet1$B1:E35].Ten) As STT, " _
             & "Ten, SL, TenWb, TenSheet From [sheet1$B1:E35]" _
             & "Group by Ten, SL,TenWb, TenSheet " _
             & "Order by TenWb"
    End With
    With Sheet2
        .[A2:E100].ClearContents
        .[A2].CopyFromRecordset adoRS
    End With
    adoRS.Close: Set adoRS = Nothing
    adoConn.Close: Set adoConn = Nothing


End Sub

Có 2 vấn đề như sau:

Nếu có n dòng dữ liệu giống nhau thì nó chỉ lấy 1 (Làm sao nếu có n dòng giống nhau thì chỉ lấy 1 nhưng phải cộng cột SL lại)
Cột SL khi ra kết quả phải là dạng số.

Đố vui về ADO, DAO. (1 người xem)

Người dùng đang xem chủ đề này

Đang đi tìm hòn đá

❆❆❆❆❆❆❆❆

File đính kèm

Hướng tới tương lai

❆❆❆❆❆❆❆❆

Hướng tới tương lai

❆❆❆❆❆❆❆❆

Hướng tới tương lai

❆❆❆❆❆❆❆❆

Hướng tới tương lai

❆❆❆❆❆❆❆❆

Đang đi tìm hòn đá

❆❆❆❆❆❆❆❆

❆❆❆❆❆❆❆❆

Hướng tới tương lai

File đính kèm

❆❆❆❆❆❆❆❆

❆❆❆❆❆❆❆❆

File đính kèm

Đang đi tìm hòn đá

❆❆❆❆❆❆❆❆

Hướng tới tương lai

❆❆❆❆❆❆❆❆

Sinh nhật lần 19 GPE