Nhờ viết code lấy trung bình cộng

Liên hệ QC
S

SoGoKu7

Thành viên chính thức
Tham gia
4/9/21
Bài viết
62
Được thích
13
Giới tính
Nữ
Em chào anh/chị
Em có dữ liệu cần tổng hợp theo dạng cộng dồn số lượng nếu trùng mã sản phẩm, các hạng mục còn lại thì lấy trung bình cộng.
Em biết nếu dữ liệu chuẩn như phía dưới thì dùng pivot sẽ rất nhanh, nhưng dữ liệu gốc còn nhiều điều kiện ràng buộc khác nên rất mong anh/chị code dùm em nhé!
Xin cảm ơn anh chị nhiều ạ!
1668917129198.png
 

File đính kèm

  • GPE2011.xlsx
    9.5 KB · Đọc: 13
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Zl: 0933707265 đã viết:
Dữ liệu thế này thì dùng công thức cơ bản là ra rồi cần gì code hả bạn?
Nhấp chuột vào đây để mở rộng...
Dạ đây chỉ là file giả định anh ạ, dữ liệu em cũng không lớn lắm, khoảng 5 trăm dòng thôi nhưng nó ràng buộc nhiều điều kiện nên em đang nhờ anh chị code, em có dùng dictionảy nhưng chỉ được cột tổng thôi. Các cột tính trung bình em chưa biết logic sao nữa.
Nhờ anh chị giúp đỡ ạ!
 
Upvote 0
SoGoKu7 đã viết:
Em chào anh/chị
Em có dữ liệu cần tổng hợp theo dạng cộng dồn số lượng nếu trùng mã sản phẩm, các hạng mục còn lại thì lấy trung bình cộng.
Em biết nếu dữ liệu chuẩn như phía dưới thì dùng pivot sẽ rất nhanh, nhưng dữ liệu gốc còn nhiều điều kiện ràng buộc khác nên rất mong anh/chị code dùm em nhé!
Xin cảm ơn anh chị nhiều ạ!
View attachment 283627
Nhấp chuột vào đây để mở rộng...
Lâu lâu không viết có vẻ ngượng tay.
Bạn tham khảo nhé!
PHP: 
Option Explicit

Sub PivotByDictionary()
    Dim sArr(), Res(), Dic As Object, Header As Range
    Dim I As Long, R As Long, Col As Integer, nCol As Integer
    Dim K As Long, lR As Long
   
    'Tat nhay man hinh
    Application.ScreenUpdating = False
    'Khai bao thu vien Dictionary
    Set Dic = CreateObject("Scripting.Dictionary")
    'Dong tieu de
    Set Header = Sheet1.Range("B5:F5")
    'Dong cuoi cung co du lieu
    lR = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
    'Mang 2 chieu chua toan bo du lieu
    sArr() = Sheet1.Range("B6:F" & lR).Value
    'Can tren cua chieu thu nhat mang sArr
    R = UBound(sArr, 1)
    'Quy dinh kich thuoc mang ket qua Res
    ReDim Res(1 To R, 1 To UBound(sArr, 2) + 1)
    'Can tren cua chieu thu hai mang Res
    Col = UBound(Res, 2)
     
    'Chay vong lap qua tung dong du lieu cua mang sArr
    For I = 1 To R
        'Kiem tra Ma san pham da ton tai trong Dictionary chua
        If Not Dic.exists(sArr(I, 1)) Then
            K = K + 1   'Tang thu tu
            'Add ma san pham la Key vao Dic voi Item la thu tu
            Dic.Add sArr(I, 1), K
            'Chay vong lap qua tung cot de lay gia tri vao Res
            For nCol = 1 To Col - 1
                Res(K, nCol) = sArr(I, nCol)
            Next nCol
            'Cot cuoi cung de tinh so lan xuat hien cua tung Ma san pham
            Res(K, Col) = 1
        Else
            'Truong hop ma san pham da ton tai
            For nCol = 2 To Col - 1
                Res(Dic.item(sArr(I, 1)), nCol) = Res(Dic.item(sArr(I, 1)), nCol) + sArr(I, nCol)
            Next nCol
            'So lan xuat hien tang them 1 lan so voi cu
            Res(Dic.Item(sArr(I, 1)), Col) = Res(Dic.Item(sArr(I, 1)), Col) + 1
        End If
    Next I
   
    'Tinh trung binh cong
    For I = 1 To K
        For nCol = 3 To Col - 1
            Res(I, nCol) = Res(I, nCol) / Res(I, Col)
        Next nCol
    Next I
   
    'Copy dong tieu de
    Header.Copy Sheet1.Range("H12")
    'Gan ket qua tu mang Res vao bang tinh
    Sheet1.Range("H13").Resize(K, Col - 1) = Res
   
    'Giai phong bo nho
    Set Dic = Nothing
    Set Header = Nothing
   
    'Mo nhay man hinh
    Application.ScreenUpdating = False
    'Thong bao hoan thanh thu tuc
    MsgBox "Done", vbInformation, "Daily Excel"
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
vanthinh3101 đã viết:
Lâu lâu không viết có vẻ ngượng tay.
Bạn tham khảo nhé!
PHP: 
Option Explicit

Sub PivotByDictionary()
    Dim sArr(), Res(), Dic As Object, Header As Range
    Dim I As Long, R As Long, Col As Integer, nCol As Integer
    Dim K As Long, lR As Long
  
    'Tat nhay man hinh
    Application.ScreenUpdating = False
    'Khai bao thu vien Dictionary
    Set Dic = CreateObject("Scripting.Dictionary")
    'Dong tieu de
    Set Header = Sheet1.Range("B5:F5")
    'Dong cuoi cung co du lieu
    lR = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
    'Mang 2 chieu chua toan bo du lieu
    sArr() = Sheet1.Range("B6:F" & lR).Value
    'Can tren cua chieu thu nhat mang sArr
    R = UBound(sArr, 1)
    'Quy dinh kich thuoc mang ket qua Res
    ReDim Res(1 To R, 1 To UBound(sArr, 2) + 1)
    'Can tren cua chieu thu hai mang Res
    Col = UBound(Res, 2)
    
    'Chay vong lap qua tung dong du lieu cua mang sArr
    For I = 1 To R
        'Kiem tra Ma san pham da ton tai trong Dictionary chua
        If Not Dic.exists(sArr(I, 1)) Then
            K = K + 1   'Tang thu tu
            'Add ma san pham la Key vao Dic voi Item la thu tu
            Dic.Add sArr(I, 1), K
            'Chay vong lap qua tung cot de lay gia tri vao Res
            For nCol = 1 To Col - 1
                Res(K, nCol) = sArr(I, nCol)
            Next nCol
            'Cot cuoi cung de tinh so lan xuat hien cua tung Ma san pham
            Res(K, Col) = 1
        Else
            'Truong hop ma san pham da ton tai
            For nCol = 2 To Col - 1
                Res(Dic.item(sArr(I, 1)), nCol) = Res(Dic.item(sArr(I, 1)), nCol) + sArr(I, nCol)
            Next nCol
            'So lan xuat hien tang them 1 lan so voi cu
            Res(Dic.Item(sArr(I, 1)), Col) = Res(Dic.Item(sArr(I, 1)), Col) + 1
        End If
    Next I
  
    'Tinh trung binh cong
    For I = 1 To K
        For nCol = 3 To Col - 1
            Res(I, nCol) = Res(I, nCol) / Res(I, Col)
        Next nCol
    Next I
  
    'Copy dong tieu de
    Header.Copy Sheet1.Range("H12")
    'Gan ket qua tu mang Res vao bang tinh
    Sheet1.Range("H13").Resize(K, Col - 1) = Res
  
    'Giai phong bo nho
    Set Dic = Nothing
    Set Header = Nothing
  
    'Mo nhay man hinh
    Application.ScreenUpdating = False
    'Thong bao hoan thanh thu tuc
    MsgBox "Done", vbInformation, "Daily Excel"
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh nhiều nhé!
chạy code ra kết quả đúng rồi anh.
 
Upvote 0
SoGoKu7 đã viết:
Dạ đây chỉ là file giả định anh ạ, dữ liệu em cũng không lớn lắm, khoảng 5 trăm dòng thôi nhưng nó ràng buộc nhiều điều kiện nên em đang nhờ anh chị code, em có dùng dictionảy nhưng chỉ được cột tổng thôi. Các cột tính trung bình em chưa biết logic sao nữa.
Nhờ anh chị giúp đỡ ạ!
Nhấp chuột vào đây để mở rộng...
Bạn thử code dưới xem sao
PHP: 
Option Explicit
Sub GPE()
    Dim Arr(), Res(), i&, j&, k&
    Dim Dic As Object, Key$, Lr&
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("B6:F" & Lr).Value
        ReDim Res(1 To UBound(Arr), 1 To 6)
        For i = 1 To UBound(Arr)
            Key = Arr(i, 1)
            If Not Dic.exists(Key) Then
                k = k + 1
                Dic.Add (Key), k
                Res(k, 1) = Key
                Res(k, 2) = Arr(i, 2)
                For j = 3 To 5
                    Res(k, j) = Arr(i, j)
                Next j
                Res(k, 6) = 1
            Else
                Res(Dic.Item(Key), 2) = Res(Dic.Item(Key), 2) + Arr(i, 2)
                For j = 3 To 5
                    Res(Dic.Item(Key), j) = Res(Dic.Item(Key), j) + Arr(i, j)
                Next j
                Res(Dic.Item(Key), 6) = Res(Dic.Item(Key), 6) + 1
            End If
        Next i
            For i = 1 To k
                For j = 3 To 5
                    Res(i, j) = Res(i, j) / Res(i, 6)
                Next j
            Next i
        If k Then
            .Range("H12:L1000").ClearContents
            .Range("H12").Resize(k, 5).Value = Res
        End If
    End With
    Set Dic = Nothing
    MsgBox "Done"
End Sub
 
Upvote 0
Zl: 0933707265 đã viết:
Bạn thử code dưới xem sao
PHP: 
Option Explicit
Sub GPE()
    Dim Arr(), Res(), i&, j&, k&
    Dim Dic As Object, Key$, Lr&
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("B6:F" & Lr).Value
        ReDim Res(1 To UBound(Arr), 1 To 6)
        For i = 1 To UBound(Arr)
            Key = Arr(i, 1)
            If Not Dic.exists(Key) Then
                k = k + 1
                Dic.Add (Key), k
                Res(k, 1) = Key
                Res(k, 2) = Arr(i, 2)
                For j = 3 To 5
                    Res(k, j) = Arr(i, j)
                Next j
                Res(k, 6) = 1
            Else
                Res(Dic.Item(Key), 2) = Res(Dic.Item(Key), 2) + Arr(i, 2)
                For j = 3 To 5
                    Res(Dic.Item(Key), j) = Res(Dic.Item(Key), j) + Arr(i, j)
                Next j
                Res(Dic.Item(Key), 6) = Res(Dic.Item(Key), 6) + 1
            End If
        Next i
            For i = 1 To k
                For j = 3 To 5
                    Res(i, j) = Res(i, j) / Res(i, 6)
                Next j
            Next i
        If k Then
            .Range("H12:L1000").ClearContents
            .Range("H12").Resize(k, 5).Value = Res
        End If
    End With
    Set Dic = Nothing
    MsgBox "Done"
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ, cảm ơn anh ạ
Kết quả chạy code đúng rồi ạ!
 
Upvote 0
SoGoKu7 đã viết:
Dạ, cảm ơn anh ạ
Kết quả chạy code đúng rồi ạ!
Nhấp chuột vào đây để mở rộng...
Thêm cách khác tham khảo
Mã: 
Option Explicit
Sub ABC()
    Dim Dic As Object, sArr(), Res(), i&, Key, S, K&, j&
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("Sheet1")
        sArr = .Range("B5:F" & .Range("B" & Rows.Count).End(3).Row).Value
        ReDim Res(1 To UBound(sArr), 1 To 5)
        For i = 2 To UBound(sArr)
            Dic(sArr(i, 1)) = Dic(sArr(i, 1)) & "," & i
        Next
        For Each Key In Dic.keys
            K = K + 1
            Res(K, 1) = Key
            S = Split(Dic(Key), ",")
            For i = 1 To UBound(S)
                For j = 2 To UBound(sArr, 2)
                    Res(K, j) = Res(K, j) + sArr(--S(i), j)
                Next
            Next
            For j = 3 To UBound(sArr, 2)
                Res(K, j) = Res(K, j) / UBound(S)
            Next
        Next
        .Range("H13:L1000").ClearContents
        .Range("H13").Resize(K, 5).Value = Res
    End With
End Sub
 
Upvote 0
Nếu có ràng buộc thì nên nói ràng buộc là gì, còn nếu như dữ liệu bài này thì nó đúng chuẩn pivot table rồi. Không phải code làm gì
 

File đính kèm

  • GPE2011.xlsx
    13.4 KB · Đọc: 3
Upvote 0
SoGoKu7 đã viết:
Em chào anh/chị
Em có dữ liệu cần tổng hợp theo dạng cộng dồn số lượng nếu trùng mã sản phẩm, các hạng mục còn lại thì lấy trung bình cộng.
Em biết nếu dữ liệu chuẩn như phía dưới thì dùng pivot sẽ rất nhanh, nhưng dữ liệu gốc còn nhiều điều kiện ràng buộc khác nên rất mong anh/chị code dùm em nhé!
Xin cảm ơn anh chị nhiều ạ!
View attachment 283627
Nhấp chuột vào đây để mở rộng...
Bạn dùng thử code sau nhé:

Mã: 
Sub TongHop_HLMT()
    With CreateObject("ADODB.Recordset")
        .Open ("Select F1,Sum(F2),Avg(F3),Avg(F4),Avg(F5) From [Sheet1$B6:F] Group By F1"), "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
        Sheet1.Range("H12").CopyFromRecordset .DataSource
    End With
End Sub
 
Upvote 0
BuiQuangThuan đã viết:
Thêm cách khác tham khảo
Mã: 
Option Explicit
Sub ABC()
    Dim Dic As Object, sArr(), Res(), i&, Key, S, K&, j&
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("Sheet1")
        sArr = .Range("B5:F" & .Range("B" & Rows.Count).End(3).Row).Value
        ReDim Res(1 To UBound(sArr), 1 To 5)
        For i = 2 To UBound(sArr)
            Dic(sArr(i, 1)) = Dic(sArr(i, 1)) & "," & i
        Next
        For Each Key In Dic.keys
            K = K + 1
            Res(K, 1) = Key
            S = Split(Dic(Key), ",")
            For i = 1 To UBound(S)
                For j = 2 To UBound(sArr, 2)
                    Res(K, j) = Res(K, j) + sArr(--S(i), j)
                Next
            Next
            For j = 3 To UBound(sArr, 2)
                Res(K, j) = Res(K, j) / UBound(S)
            Next
        Next
        .Range("H13:L1000").ClearContents
        .Range("H13").Resize(K, 5).Value = Res
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Một cách viết khác dựa trên code bạn:
Mã: 
Option Explicit
Sub ABC1()
    Dim Dic As Object, sArr(), Res(), i&, sKey$, K&, j&, sItem
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("Sheet1")
        sArr = .Range("B6:F" & .Range("B" & Rows.Count).End(3).Row).Value
        ReDim Res(1 To UBound(sArr), 1 To 5)
        For i = 1 To UBound(sArr)
            sKey = sArr(i, 1)
            If Not Dic.exists(sKey) Then
                K = K + 1
                Dic.Add sKey, Array(K, 1)
                Res(K, 1) = sKey
            Else
                sItem = Dic.Item(sKey)
                sItem(1) = sItem(1) + 1
                Dic.Item(sKey) = sItem
            End If
            sItem = Dic.Item(sKey)
            Res(sItem(0), 2) = Res(sItem(0), 2) + sArr(i, 2)
            For j = 3 To UBound(sArr, 2)
                Res(sItem(0), j) = (Res(sItem(0), j) * (sItem(1) - 1) + sArr(i, j)) / sItem(1)
            Next
        Next
        .Range("H13:L1000").ClearContents
        .Range("H13").Resize(K, 5).Value = Res
    End With
End Sub
 
Upvote 0
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

Huy@@*
Tách NKC Nhiều nợ, nhiều có VBA
Trả lời
5
Đọc
85
Maika8008
Maika8008
E
  • Question
Tạo bảng lọc theo điều kiện
Trả lời
7
Đọc
100
Hoàng Tuấn 868
H
N
Giúp em hàm Aggregate không chạy được trên Google sheet ah
Trả lời
3
Đọc
35
BuiQuangThuan
B
Huy@@*
Giải đáp giùm em, cách khắc phục lỗi này trên VBA
2
Trả lời
20
Đọc
248
nttrung_proneu
nttrung_proneu
Bùi Thúy Thúy
  • Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
62
Đọc
18K
HeSanbi
HeSanbi
B
Nhờ anh/chị giúp em tìm hàm cho công thức tính lương
Trả lời
0
Đọc
38
Bobomkkk
B
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
174
Đọc
9K
tienphat85
tienphat85
H
Timesheet: Excel hay Power Apps/ Forms? Cách sắp xếp dữ liệu?
Trả lời
4
Đọc
352
duykhanh3488
D
vova2209
Index kết hợp với match 2 điều kiện
Trả lời
14
Đọc
1K
dunghtgiga
dunghtgiga
D
  • Question
Xin cách tạo tab và button cho Add-in trên ribbon Maintabs
Trả lời
2
Đọc
84
Decepticon
D
N
cộng các dữ liệu không trùng nhau
Trả lời
12
Đọc
187
Nguyễn Hiền1508
N
T
Chèn dữ liệu từ sheet này qua sheet khác theo điều kiện
Trả lời
3
Đọc
125
HieuCD
H
T
Trùng 2 lần: Tìm dữ liệu nhiều điều kiện
Trả lời
0
Đọc
75
Thulib
T
N
  • Question
Xin mã code ẩn hiện dòng theo điều kiện
Trả lời
10
Đọc
110
Nguyễn Diêu Hiền
N
K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
11
Đọc
198
quocphuoc88
quocphuoc88
N
Công thức tính số phù hợp với % mong muốn
Trả lời
9
Đọc
158
CHAOQUAY
C
B
Giúp em xử lý lỗi macro khi chạy VBA
2
Trả lời
21
Đọc
452
huhumalu
H
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
6
Đọc
334
DeTong
D
T
cả nhà hỗ trợ giúp em là em phải dùng hàm gì cho đúng ạ, em làm mãi không được
    • Cười
Trả lời
2
Đọc
99
DeTong
D
nguyenanhhoa
Nhờ các bác giúp: e muốn tô màu khác nhau đối với các ô giống nhau về giá trị
    • Cười
Trả lời
7
Đọc
141
SA_DQ
SA_DQ
Xem thêm…

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