Thử code này nhé.
Sub TongHop()
Dim cn As Object, SQL As String, duonglinh, arr, dic As Object
Dim ketqua(1 To 10000, 1 To 2), b As Long, a As Long, i As Long, lr As Long, dk As String
Set dic = CreateObject("scripting.dictionary")
Set cn = CreateObject("ADODB.Connection") 'khai báo cho ADO
Application.ScreenUpdating = False 'Tat cap nhap man hinh
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True 'cho chon nhieu file
.Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1 'chi hien cac duoi excel
If Not .Show = -1 Then 'Kiêm tra xem da chon file chua
MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
Exit Sub
End If
For Each duonglinh In .SelectedItems
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & duonglinh & ";Extended Properties=""Excel 12.0;HDR=No"";" ' mo file excel
SQL = "SELECT * FROM [Tongket$C3:D10000] where f1 is not null"
arr = chuyenmang(cn.Execute(SQL).GetRows)
For i = 1 To UBound(arr)
dk = arr(i, 1)
If Not dic.exists(dk) Then
a = a + 1
dic.Add dk, a
ketqua(a, 1) = arr(i, 1)
ketqua(a, 2) = arr(i, 2)
Else
b = dic.Item(dk)
ketqua(b, 2) = ketqua(b, 2) + arr(i, 2)
End If
Next i
cn.Close 'dong file
Next
End With
With Sheets("baocao")
lr = .Range("A" & Rows.Count).End(xlUp).Row 'xác dinh dong cuoi cua bang tong hop
If lr > 1 Then .Range("A2:B" & lr).ClearContents 'neu dong cuoi lon hon 15 thi xoa
If a Then .Range("A2:B2").Resize(a).Value = ketqua
End With
Application.ScreenUpdating = True 'bat cap nhap man hinh
Set cn = Nothing
Set dic = Nothing
End Sub
Private Function chuyenmang(ByVal arr) As Variant
Dim kq(), i As Long, j As Long
ReDim kq(1 To UBound(arr, 2) + 1, 1 To UBound(arr, 1) + 1)
For i = LBound(arr, 2) To UBound(arr, 2)
For j = LBound(arr, 1) To UBound(arr, 1)
kq(i + 1, j + 1) = arr(j, i)
Next j
Next i
chuyenmang = kq
End FunctionCode chạy đúng ý em, cảm ơn bác đã giúp ạ. Mấy bữa trước em cũng có mò mẫm code trên mà làm ko ra, ko nghĩ tới phải có dic để lọc (nếu em không nhầm thì kênh yt của bác là tin học Phong An ạ). Em cứ tưởng là chỉ cần thêm 1 vòng lặp nữa để sum đè lên recodset thì không cần gọi thêm dic. Cảm ơn bác nhiều ạ.
Bác giúp em cái đường link bài cũ được không ạ, em cũng muốn xem để sau này có lúc dùng tới ạ.
Học cách mò tìm "sau này có nhiều lúc dùng" hơn.
Bạn thử code này.Ở trong câu lệnh SQL đã có câu lệnh bỏ Null rồi mà.
Sub TongHop()
Dim cn As Object, SQL As String, duonglinh, arr, dic As Object
Dim ketqua(1 To 10000, 1 To 2), b As Long, a As Long, i As Long, lr As Long, dk As String
Set dic = CreateObject("scripting.dictionary")
Set cn = CreateObject("ADODB.Connection") 'khai báo cho ADO
Application.ScreenUpdating = False 'Tat cap nhap man hinh
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True 'cho chon nhieu file
.Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1 'chi hien cac duoi excel
If Not .Show = -1 Then 'Kiêm tra xem da chon file chua
MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
Exit Sub
End If
For Each duonglinh In .SelectedItems
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & duonglinh & ";Extended Properties=""Excel 12.0;HDR=No"";" ' mo file excel
SQL = "SELECT * FROM [Tongket$C2:D10000] where f1 is not null"
arr = chuyenmang(cn.Execute(SQL).GetRows)
For i = 2 To UBound(arr)
dk = arr(i, 1)
If Not dic.exists(dk) Then
a = a + 1
dic.Add dk, a
ketqua(a, 1) = arr(i, 1)
ketqua(a, 2) = arr(i, 2)
Else
b = dic.Item(dk)
ketqua(b, 2) = ketqua(b, 2) + arr(i, 2)
End If
Next i
cn.Close 'dong file
Next
End With
With Sheets("baocao")
lr = .Range("A" & Rows.Count).End(xlUp).Row 'xác dinh dong cuoi cua bang tong hop
If lr > 1 Then .Range("A2:B" & lr).ClearContents 'neu dong cuoi lon hon 15 thi xoa
If a Then .Range("A2:B2").Resize(a).Value = ketqua
End With
Application.ScreenUpdating = True 'bat cap nhap man hinh
Set cn = Nothing
Set dic = Nothing
End Sub
Private Function chuyenmang(ByVal arr) As Variant
Dim kq(), i As Long, j As Long
ReDim kq(1 To UBound(arr, 2) + 1, 1 To UBound(arr, 1) + 1)
For i = LBound(arr, 2) To UBound(arr, 2)
For j = LBound(arr, 1) To UBound(arr, 1)
kq(i + 1, j + 1) = arr(j, i)
Next j
Next i
chuyenmang = kq
End Function
Bạn thử code sau nhé:
Sub TongHop_HLMT()
Dim strPath As Variant, strSQL As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Add "Excel Files", "*.xls*", 1
If Not .Show = -1 Then
MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
Exit Sub
End If
For Each strPath In .SelectedItems
strSQL = strSQL & " Union All Select [Name],[SubTotal] From [EXCEL 12.0;Database=" & strPath & "].[TongKet$] Where [Name] Is Not Null"
Next
End With
With CreateObject("ADODB.Connection")
.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0 Xml;"
Sheet5.Range("E2").CopyFromRecordset .Execute("Select [Name], Sum(SubTotal) From (" & Right(strSQL, Len(strSQL) - 10) & ") Group By [Name]")
End With
End SubCode này hay quá, nhờ anh admin xử lý giúp em nếu trong các file nguồn em thêm 2 cột màu vàng này nữa thì code của anh sẽ sửa như thế nào ạ.
Thêm 2 cột đó vào ở file nguồn nhưng kết quả của bạn vẫn không đổi hay là kết quả của bạn có thêm 2 cột đó nữa vậy bạn?
Nịnh quá đi thôi.
...àơi tí vậyDạ anh kết quả có thêm 2 cột màu vàng nữa ạ.
Bạn thử code sửa lại như sau nhé:
Sub TongHop_HLMT()
Dim strPath As Variant, strSQL As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Add "Excel Files", "*.xls*", 1
If Not .Show = -1 Then
MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
Exit Sub
End If
For Each strPath In .SelectedItems
strSQL = strSQL & " Union All Select [Code],[Name],[Group],[SubTotal] From [EXCEL 12.0;Database=" & strPath & "].[TongKet$] Where [Name] Is Not Null"
Next
End With
With CreateObject("ADODB.Connection")
.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0 Xml;"
Sheet5.Range("E2").CopyFromRecordset .Execute("Select [Code],[Name],[Group],Sum(SubTotal) From (" & Right(strSQL, Len(strSQL) - 10) & ") Group By [Code],[Name],[Group]")
End With
End SubCảm ơn anh admin nhiều, em hiểu cách làm rồi.
Bạn lấy bao nhiêu cột mà không phải cột tính toán thì bắt buộc phải gom nhóm (Group By) bấy nhiêu cột đó. Có nghĩa là điều kiện gom nhóm phải ít nhất là các cột không tính toán được lấy ra.
Vâng ạ, e thấy trong câu lệnh đã có check null rồi, nhưng không hiểu sao khi em gán thông báo if f1 is null then msgbox .... thì lại không hiện lên.
Code của admin hay quá hay, bữa giờ em cứ loay hoay hết sum rồi lại group trong strSQL, xong hết mới thực thi câu CopyFormRecordset. Thậm chí làm 2-3 cái vòng lặp cho strSQL để nó ra kết quả hoàn chỉnh mà không được. Không hề biết có cách xử lý sau khi CopyFromRecordset. Cảm ơn admin, đoạn group sau CopyFromRecordset quả thực làm em mở mang.
Không phải là xử lý sau khi CopyFromRecordset mà là cái CopyFromRecordset đó được lấy dữ liệu xuống sheet từ chỗ chứa dữ liệu sau khi truy vấn nhé bạn.
