Xin giúp đỡ tính tổng bằng VBA

Chia sẻ bởi:hands

★★★★★

‹ Code tự động kích họat mở File... Tính tổng theo điều kiện đạt sản... ›

Quảng cáo

Em xin chào anh chị trong diễn đàn, do dữ liệu rất lớn, em có dùng sumifs thì 10 15 phút mới tính toán xong, vậy nhờ anh chị trong diễn đàn viết code giúp em, thay công thức sumifs (các ô vùng màu vàng) thành code giúp em với ạ. Em xin chân thành cám ơn ạ

Thử xem Code VBA củ chuối này.

Option Explicit
Sub TongSumIFs()
Dim i&, j&, Lr&, t&, k&, R&, Lr1&, d&
Dim Arr(), Res()
Dim Dic As Object
Dim Key, Temp
With Sheets("DATA")
Lr = .Cells(100000, 1).End(xlUp).Row
Arr = .Range("A4:AD" & Lr).Value
R = UBound(Arr)
End With
Set Dic = CreateObject("Scripting.Dictionary")
ReDim Res(1 To R, 1 To 1)
For i = 1 To R
    If Arr(i, 9) <> Empty Then
        Key = Arr(i, 9) & "#" & Arr(i, 23)
            If Not Dic.Exists(Key) Then
                t = t + 1: Dic.Add (Key), t
                Res(t, 1) = Arr(i, 30)
            Else
                k = Dic.Item(Key)
                Res(k, 1) = Res(k, 1) + Arr(i, 30)
            End If
    End If
Next i
With Sheets("THUC TE")
    Lr1 = .Cells(100000, 1).End(xlUp).Row
    For i = 5 To Lr1
        If .Cells(i, 1) <> Empty And .Cells(i, 1) Like "CONGDOAN" & "*" Then
        For j = 5 To 35
            Temp = .Cells(i, 1) & "#" & .Cells(3, j)
            If Dic.Exists(Temp) Then
                d = Dic.Item(Temp)
                .Cells(i, j) = Res(d, 1)
            End If
        Next j
        End If
    Next i
End With
Set Dic = Nothing
MsgBox "Done"
End Sub

Dạ, anh sửa giúp em ạ, cột tên hàng lúc là CONGDOAN , lúc là XUONG hoặc BOPHAN… và khi chạy code kết quả cũ xóa đi thay kết quả mới vào (code TongSumIFs1 của anh chạy đúng), và em chỉ muốn ra kết quả chỗ vùng bôi vàng các phần khác công thức giữ nguyên ạ.
Mong anh giúp đỡ em ạ, em cám ơn anh ạ

Nếu Các tên hàng (thành phần) ở cột A sheets Thuc Te ít (XUONG, BO PHAN, CONG ĐOAN=3= ít ) Thì Bạn thử thay dòng

If Arr1(i, 1) <> Empty And Arr1(i, 1) Like "CONGDOAN" & "*"  Then

thành

If Arr1(i, 1) <> Empty And (Arr1(i, 1) Like "CONGDOAN" & "*" Or Arr1(i, 1) Like "XUONG" & "*" Or Arr1(i, 1) Like "BO PHAN" & "*") Then

và chạy thử.
Nếu nhiều thì phải lập 1 bảng và cho code duyêt từng Ô trong bảng ấy hoặc đưa bảng ấy vào 1 mảng và code duyệt từng phần tử của mảng ấy để so sánh với cột A: đại loại là
Ví dự: Bảng ấy là 1 cột (từ X1:X100) và nằm trên Sheet THUC TE. vậy thì code sẽ thế này

'Đây là lấy từng Cell trong bảng ấy, nếu lấy từng phần tử trong mảng (được tạo từ bảng ấy) thì bạn tự sửa nhé
......

If Arr(i,1)<> Emp ty then
For Z=1 to 100
If Arr(i,1)=.Range("X"&z) then TenHang=Arr(i,1)
next Z
 For j = 5 To 35
            Temp = TenHang & "#" & Arr1(1, j)
......

Nhớ khai báo thêm các biến TenHang, Z
và chạy thử.
2. Code TongSumIFs1 là làm dạng mảng kết quả. do vậy khi gán kết quả xuống sh nó sẽ ghi đè lên vùng kết quả.
3. Code TongSumIfs là kết quả được gán trực tiếp vào các Cell của sheet. Bạn chạy thử code TongSunIFs chưa -các dòng Của phần tính toán sẽ không bị xóa.
Chúc thành công.

www.giaiphapexcel.com/diendan/threads/xin-gi%C3%BAp-%C4%91%E1%BB%A1-t%C3%ADnh-t%E1%BB%95ng-b%E1%BA%B1ng-vba.163604/post-1091201

Khóa học SprinGO phù hợp

Khóa học Power PI – Ứng dung trong Nhân sự

TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...

Xem khóa học

★★★★★ 5 ★ 1 👤 3 ▥ 0

‹ Code tự động kích họat mở File Excel... Tính tổng theo điều kiện đạt sản lượng ›

Quảng cáo

Bạn nên đọc

3 Responses

hands says:

23/12/2022 at 1:33 pm

Dạ. Em có đọc và thử rùi. Em muốn dùng TongSumIFs1 để ghi lên vùng kết quả, em vẫn đang mắc sửa như nào để cho các vùng ngoài chỗ bôi vàng (E5:AI25 và E32:AI45 , E52:E59…), Không bị mất công thức. Mong anh giải đáp giúp em với. Em cám ơn ạ

Thử code này xem sao nhé.

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, m&, n&, sum As Long
Dim grp1 As Range, grp2 As Range, grp3 As Range, grp4 As Range
Dim ngay, nhom, hang, data, rng, res()
With Sheets("DATA")
lr = .Cells(Rows.Count, "A").End(xlUp) 'xác dinh dong cuoi cung can cu vao cot A
data = .Range("I2:AD" & lr).Value ' gan du lieu trong DATA vao data
End With
With Sheets("THUC TE")
Set grp1 = .Range("A5:A" & .Range("A5").End(xlDown).Row) 'neu nhom hang 1 bat dau tu o A5
Set grp2 = .Range("A32:A" & .Range("A32").End(xlDown).Row) 'neu nhom hang 2 bat dau tu o A32
Set grp3 = .Range("A52:A" & .Range("A52").End(xlDown).Row) 'neu nhom hang 3 bat dau tu o A52
Set grp4 = .Range("A66:A" & .Range("A66").End(xlDown).Row) 'neu nhom hang 4 bat dau tu o A66
ngay = .Range("E3:AI3").Value ' vung tieu de ngay
nhom = Array(grp1, grp2, grp3, grp4) ' tap hop cua 4 nhom hang
For n = 0 To UBound(nhom) ' duyet qua tung nhom hang
rng = nhom(n).Value ' gan gia tri vao rng
ReDim res(1 To UBound(rng), 1 To UBound(ngay, 2))
For i = 1 To UBound(rng) ' duyet qua tung ten hang
For j = 1 To UBound(ngay, 2) ' duyet qua tung ngay
sum = 0
For m = 1 To UBound(data) ' duyet qua tung dong trong data
'neu thoa 2 dieu kien ten hang va ngay thi cong luy ke lai voi nhau
If data(m, 1) = rng(i, 1) And data(m, 15) = ngay(1, j) Then
sum = sum + data(m, 22)
res(i, j) = sum
End If
Next
Next
Next
nhom(n).Offset(, 4).Resize(UBound(res), UBound(res, 2)).Value = res ' dan ket qua vao sheet
Next
End With
End Sub

http://www.giaiphapexcel.com/diendan/threads/xin-gi%C3%BAp-%C4%91%E1%BB%A1-t%C3%ADnh-t%E1%BB%95ng-b%E1%BA%B1ng-vba.163604/post-1091319
Bạn chạy thử Modul 2 trong đó có Sub TongSumIFs (trong file đính kèm tôi đã gửi bạn)
Trong đó kết quả được trả về theo từng dòng của Cột A nếu thỏa điều kiện là "CONG ĐOAN &*", các dòng không thỏa thì không động đến, nên vẫn còn công thức.
Còn Code thì đây: vẫn là code chỉ tính có 1 thành phần là CÔNGĐOẠN mà chưa làm với trường hợp nhiều Thành phần khác như :XUONG, BÔ PHẬN….
Bạn cứ thử code này và thay thế nhe tôi hướng dẫn,
```
Option Explicit
Sub TongSumIFs()
Dim i&, j&, Lr&, t&, k&, R&, Lr1&, d&, R1&, tt&
Dim Arr(), Res(), Arr1(), Res1()
Dim Dic As Object
Dim Key, Temp
With Sheets("DATA")
Lr = .Cells(100000, 1).End(xlUp).Row
Arr = .Range("A4:AD" & Lr).Value
R = UBound(Arr)
End With
Set Dic = CreateObject("Scripting.Dictionary")
ReDim Res(1 To R, 1 To 1)
For i = 1 To R
    If Arr(i, 9) <> Empty Then
        Key = Arr(i, 9) & "#" & Arr(i, 23)
            If Not Dic.Exists(Key) Then
                t = t + 1: Dic.Add (Key), t
                Res(t, 1) = Arr(i, 30)
            Else
                k = Dic.Item(Key)
                Res(k, 1) = Res(k, 1) + Arr(i, 30)
            End If
    End If
Next i
With Sheets("THUC TE")
    Lr1 = .Cells(100000, 1).End(xlUp).Row
    For i = 5 To Lr1
        If .Cells(i, 1) <> Empty And .Cells(i, 1) Like "CONGDOAN" & "*" Then
        For j = 5 To 35
            Temp = .Cells(i, 1) & "#" & .Cells(3, j)
            If Dic.Exists(Temp) Then
                d = Dic.Item(Temp)
                .Cells(i, j) = Res(d, 1)
            End If
        Next j
        End If
    Next i
End With

Set Dic = Nothing
MsgBox "Done"
End Sub
```
Reply
hands says:

28/12/2022 at 8:58 am

Dạ . Tên hàng của em chỉ có 3 mục chính(em thay công thức anh ok rồi).em đang dùng code TongSumIFs1 đang ok. Em đang mắc chỗ muốn kết quả ra vùng màu vàng (E5:AI25 và E32:AI45 , E52:E59…), Các vùng khác không bị mất công thức Mong anh giúp em đoạn này với ạ. Em cám ơn anh ạ

Bạn chạy thử Modul 2 trong đó có Sub TongSumIFs (trong file đính kèm tôi đã gửi bạn)
Trong đó kết quả được trả về theo từng dòng của Cột A nếu thỏa điều kiện là "CONG ĐOAN &*", các dòng không thỏa thì không động đến, nên vẫn còn công thức.
Còn Code thì đây: vẫn là code chỉ tính có 1 thành phần là CÔNGĐOẠN mà chưa làm với trường hợp nhiều Thành phần khác như :XUONG, BÔ PHẬN….
Bạn cứ thử code này và thay thế nhe tôi hướng dẫn,
```
Option Explicit
Sub TongSumIFs()
Dim i&, j&, Lr&, t&, k&, R&, Lr1&, d&, R1&, tt&
Dim Arr(), Res(), Arr1(), Res1()
Dim Dic As Object
Dim Key, Temp
With Sheets("DATA")
Lr = .Cells(100000, 1).End(xlUp).Row
Arr = .Range("A4:AD" & Lr).Value
R = UBound(Arr)
End With
Set Dic = CreateObject("Scripting.Dictionary")
ReDim Res(1 To R, 1 To 1)
For i = 1 To R
    If Arr(i, 9) <> Empty Then
        Key = Arr(i, 9) & "#" & Arr(i, 23)
            If Not Dic.Exists(Key) Then
                t = t + 1: Dic.Add (Key), t
                Res(t, 1) = Arr(i, 30)
            Else
                k = Dic.Item(Key)
                Res(k, 1) = Res(k, 1) + Arr(i, 30)
            End If
    End If
Next i
With Sheets("THUC TE")
    Lr1 = .Cells(100000, 1).End(xlUp).Row
    For i = 5 To Lr1
        If .Cells(i, 1) <> Empty And .Cells(i, 1) Like "CONGDOAN" & "*" Then
        For j = 5 To 35
            Temp = .Cells(i, 1) & "#" & .Cells(3, j)
            If Dic.Exists(Temp) Then
                d = Dic.Item(Temp)
                .Cells(i, j) = Res(d, 1)
            End If
        Next j
        End If
    Next i
End With

Set Dic = Nothing
MsgBox "Done"
End Sub
```
http://www.giaiphapexcel.com/diendan/threads/xin-gi%C3%BAp-%C4%91%E1%BB%A1-t%C3%ADnh-t%E1%BB%95ng-b%E1%BA%B1ng-vba.163604/post-1091323

Reply

hands says:

28/12/2022 at 8:58 am

Góp vui . . .

Option Explicit
Option Compare Text
  Sub XYZ()
  Dim arr(), aNgay(), aHang(), res(), Dic As Object, key$, str$
  Dim i&, r&, j&, sRow&, sCol&, fR&

Set Dic = CreateObject("Scripting.Dictionary")
  With Sheets("DATA")
    arr = .Range("I3", .Range("AD" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr)
  For i = 1 To sRow
    If arr(i, 1) <> Empty Then
      key = arr(i, 1) & "|" & arr(i, 15)
      Dic.Item(key) = Dic.Item(key) + arr(i, 22)
    End If
  Next i

str = "T? l? ho?t ??ng" 'Ty le hoat dong
  With Sheets("THUC TE")
    aNgay = .Range("E3", .Range("AAA3").End(xlToLeft)).Value
    sRow = .Range("A" & Rows.Count).End(xlUp).Row - 4 'Dong cuoi, loai bo 4 dong Tong
    aHang = .Range("A1:A" & sRow + 1).Value
    sCol = UBound(aNgay, 2)
    aHang(4, 1) = str
    For i = 4 To sRow
      If aHang(i, 1) Like str Then
        fR = i + 1
        ReDim res(fR To sRow, 1 To sCol)
      ElseIf fR > 0 Then
        If aHang(i + 1, 1) = Empty Then
          .Range("E" & fR).Resize(i - fR + 1, sCol) = res
          fR = -9999
        Else
          For j = 1 To sCol
            res(i, j) = Dic(aHang(i, 1) & "|" & aNgay(1, j))
          Next j
        End If
      End If
    Next i
  End With
  Set Dic = Nothing
End Sub