Nhờ sửa code tính tổng khi gộp dữ liệu bằng ADO

Chia sẻ bởi:hands

★★★★★

‹ Tự động chèn thêm dòng và copy... LỌC DỮ LIỆU TỪ NHIỀU SHEET VÀ... ›

Quảng cáo

Mình cần anh chị em giúp đỡ sửa đoạn code trong file tổng kết (code này mót từ Mr.DBA) hoặc viết giúp đoạn code mới giống vậy, để có thể vừa gom được dữ liệu từ các file con (chọn được file nào muốn gom dữ liệu), vừa tính tổng điểm của những người trùng như trong sheet tên PowerQuery. Rất cảm ơn anh chị giúp đỡ ạ.

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 Function

www.giaiphapexcel.com/diendan/threads/nh%E1%BB%9D-s%E1%BB%ADa-code-t%C3%ADnh-t%E1%BB%95ng-khi-g%E1%BB%99p-d%E1%BB%AF-li%E1%BB%87u-b%E1%BA%B1ng-ado.163339/post-1089541