Xin giúp đỡ code tập hợp dữ liệu các sheet con về sheet tổng hợp theo điều kiện (2 người xem)

[quoc_huy1702]

Yêu cầu cũ

Chào mọi người, em dở khoảng code; đang có nhu cầu như sau:

Yêu cầu mới:
Ngoài ra, có 1 yêu cầu mới phát sinh làm thay đổi cột, thứ tự cột cũng như điều kiện, em mày mò không ra cách giải quyết; lại mang lên nhờ mọi người hỗ trợ giúp em

 

[Quang_Hải]

Chào mọi người, em dở khoảng code; đang có nhu cầu như sau:

Xem thử code nhà nghèo. Khi nào khá hơn viết bằng ADO cho sang chút

Sub TONGHOP()
Dim Sarr(), Darr(), I As Long, J As Long, X As Long
Dim Item, SheetString
SheetString = Array("TAM NONG", "VINH LONG", "TIEN GIANG", "KIEN GIANG")
ReDim Darr(1 To 65536, 1 To 21)
For Each Item In SheetString
    With Sheets(Item)
        Sarr = .Range(.[A5], .[U65536].End(3)).Value
    End With
    For I = 1 To UBound(Sarr)
        If Sarr(I, 15) <> "" Then
            J = J + 1
            For X = 1 To 21
                Darr(J, X) = Sarr(I, X)
            Next
        End If
    Next
Next
Sheets("TONG HOP").[A9:U20000].ClearContents
Sheets("TONG HOP").[A9].Resize(J, 21) = Darr
End Sub

 

[Quang_Hải]

Thêm 1 cách dùng ADO
Mong anh chị có kinh nghiệm về ADO góp ý code này dùm vì code chạy mà kết quả ra trật lất hà

Sub ADO()
    Dim item, Sheet(), FileName As String
    Dim CNN As Object, REC As Object, StrRequest As String
    Set CNN = CreateObject("ADODB.Connection")
    Set REC = CreateObject("ADODB.Recordset")
    FileName = ThisWorkbook.FullName
    If Application.Version < 12 Then
        CNN.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
         "Data Source=" & FileName & ";Extended Properties=""Excel 8.0;HDR=NO;"";"
    Else
        CNN.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
    End If
    CNN.Open
    Sheets("TONG HOP").[A9:U65536].ClearContents
    Sheet = Array("TAM NONG", "VINH LONG", "KIEN GIANG", "TIEN GIANG")
    For Each item In Sheet
        StrRequest = "SELECT * FROM [" & item & "$A5:U10000] where F15 is not Null "
        REC.Open StrRequest, CNN
        Sheets("TONG HOP").[A65536].End(3).Offset(1).CopyFromRecordset REC
        REC.Close
    Next
    CNN.Close
End Sub

 

[nmhung49]

Anh thêm IMEX=1 vào câu lệnh kết nối xem sau
Cũng có thể dùng Union All
[GPECODE=vb]
Sub TongHop()
Dim Cnn As Object, rst As Object
Dim SQL As String, ws As Worksheet
Set Cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
With Cnn
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data source=" & ThisWorkbook.FullName & _
";Extended properties=""Excel 12.0;IMEX=1;HDR=Yes"";"
.Open
End With
For Each ws In Worksheets
If ws.CodeName <> "Sheet1" And ws.CodeName <> "Sheet3" Then SQL = SQL & " " & "[" & ws.Name & "$A4:U10000]"
Next
SQL = "SELECT * FROM " & Replace(Trim(SQL), " ", " Where [ID] Is Not Null UNION ALL SELECT * FROM ") & " Where [ID] Is Not Null"
rst.Open SQL, Cnn, 3, 3, 1
With Sheet1
.Range("A9:U100000").ClearContents
.[A9].CopyFromRecordset rst
End With
rst.Close: Set rst = Nothing
Cnn.Close: Set Cnn = Nothing
End Sub
[/GPECODE]

Ặc ...ặc... giờ mới phát hiện bị lỗi ở cột Phục lục vẫn thiếu 2 dòng 01-TN không biết lỗi gì, các bạn kiểm tra giúp coi máy có bị trường hợp đó không?

 

[quoc_huy1702]

Chào các anh, code của anh Hải em xem thì học lóm được 1 chút; Còn code ADO thì mù tịt; chưa hiểu nhiều
Cho em hỏi ở HCM có chỗ nào dạy excel nâng cao về mấy vụ code này ko? em muốn ghi danh để nâng cao chuyên môn

Ngoài ra, có 1 yêu cầu mới phát sinh làm thay đổi cột, thứ tự cột cũng như điều kiện, em mày mò không ra cách giải quyết; lại mang lên nhờ mọi người hỗ trợ giúp em

Ghi chú:

Code cũ của anh Hải và bạn nmhung49 em vẫn giữ nguyên code cũ chưa xóa

 

[quoc_huy1702]

ai giúp dùm e giải bài này với;

 

[Ba Tê]

ai giúp dùm e giải bài này với;

Thử file này xem sao