Đố vui về ADO, DAO.

Liên hệ QC
"FROM [Data$] where trim(Partition([id],1,100,10)) in ('1: 10','91:100')"
Nhấp chuột vào đây để mở rộng...

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.
 
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.
  1. 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.
  2. 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?
 

File đính kèm

  • GPE.rar
    30 KB · Đọc: 31
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.
  1. 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.
  2. 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?
Nhấp chuột vào đây để mở rộng...
Em xin đưa ra giải phá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
 
dhn46 đã viết:
Em xin đưa ra giải phá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
Nhấp chuột vào đây để mở rộng...

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.
 
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.
Nhấp chuột vào đây để mở rộng...

Vâng anh HLMT, tới thời điểm này em cũng chưa thuộc hết các phần trong sub, chủ yếu là Copy Paste rồi chỉnh sửa. Anh có bí quyết gì để học các cấu trúc nhanh hơn không, bật mí 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
 
dhn46 đã viết:
Vâng anh HLMT, tới thời điểm này em cũng chưa thuộc hết các phần trong sub, chủ yếu là Copy Paste rồi chỉnh sửa. Anh có bí quyết gì để học các cấu trúc nhanh hơn không, bật mí 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ấp chuột vào đây để mở rộng...

- Để 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
 
Lần chỉnh sửa cuối:
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
Nhấp chuột vào đây để mở rộng...

Dạ vâng. Em thiếu phần
Mã: 
On Error Go to Handle

Anh HLMT nếu rút gọn phần truy vấn thì em bỏ hết a, b, c đi thì còn rút được nữa không anh?
 
dhn46 đã viết:
Dạ vâng. Em thiếu phần
Mã: 
On Error Go to Handle

Anh HLMT nếu rút gọn phần truy vấn thì em bỏ hết a, b, c đi thì còn rút được nữa không anh?
Nhấp chuột vào đây để mở rộng...

Ngoài a, b, c ra vẫn còn chổ để rút gọn đó bạn.
 
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.
Nhấp chuột vào đây để mở rộng...
Vậy em sửa như sau có rú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"
 
dhn46 đã viết:
Vậy em sửa như sau có rú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"
Nhấp chuột vào đây để mở rộng...
Có thể rút ngắn lại biến Ver.
 
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.
 
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.
Nhấp chuột vào đây để mở rộng...

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.
 
dhn46 đã viết:
Vậy em sửa như sau có rú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"
Nhấp chuột vào đây để mở rộng...

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é.
 
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é.
Nhấp chuột vào đây để mở rộng...

Anh HLMT, em đã chỉnh sửa như trên sao file vẫn lỗi, anh kiểm tra giúp em nhé
 

File đính kèm

  • KetQua.zip
    17.1 KB · Đọc: 17
dhn46 đã viết:
Anh HLMT, em đã chỉnh sửa như trên sao file vẫn lỗi, anh kiểm tra giúp em nhé
Nhấp chuột vào đây để mở rộng...
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"
 
Đá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.
 

File đính kèm

  • STT_GPE.xls
    44.5 KB · Đọc: 26
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.
Nhấp chuột vào đây để mở rộng...

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)
 
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)
Nhấp chuột vào đây để mở rộng...
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]
 
Lần chỉnh sửa cuối:
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.
Nhấp chuột vào đây để mở rộng...
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
 
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
Nhấp chuột vào đây để mở rộng...
Có 2 vấn đề như sau:
  1. 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)
  2. Cột SL khi ra kết quả phải là dạng số.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

phunguyenkt
  • Question
MN cho em xin phần mềm chuyển đổi số sang chữ với ạ, và ko có chữ chẵn, em cảm ơn
Trả lời
2
Đọc
120
ghouls1
ghouls1
L
[xin nhờ giúp đỡ] hàm trích xuất ra dữ liệu thỏa mã điều kiện và ghi vào một ô
Trả lời
11
Đọc
425
tranhungdao12a3
T
H
Tính tổng có điều kiện
2
Trả lời
20
Đọc
332
hoaiantrinh
H
vova2209
Hàm if điều kiện mảng
Trả lời
19
Đọc
362
ptm0412
ptm0412
dunghtgiga
Không cho người khác chỉnh sửa nội dung bảng tính
Trả lời
4
Đọc
146
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom