Ứng dụng hàm SUMIFS trong VBA

Liên hệ QC
huunguyenfi

huunguyenfi

Thành viên mới
Tham gia
10/1/12
Bài viết
25
Được thích
5
Giới tính
Nam
Xin chào Các Anh Chị ,

Thay vì sử dụng hàm Sumifs trực tiếp trên excel nhưng vì dữ liệu quá lớn nên mình muốn học cách chạy hàm này trong VBA . Mình lần mò làm theo trên net chỉ nhưng cả ngày vẫn chưa chạy được . Anh chị nào biết làm ơn xem qua file đính kèm và hướng đãn giúp mình với ạh . Xin cám ơn nhiều .
 

File đính kèm

  • sumifs vba.xlsm
    34.4 KB · Đọc: 65
Sắp xếp theo thời gian sắp xếp theo bầu chọn
anhtuan2939 đã viết:
Bạn chạy thử xem
PHP: 
Sub sumifs()
    Dim dic As Object, sArr(), dArr()
    Dim i As Long, j As Long, lr As Long, Row As Long, Col As Long, R1 As Long, C1 As Long, a As Long, b As Long
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("tonghop")
            lr = .Range("B" & Rows.Count).End(xlUp).Row
        sArr = .Range("B1:AI" & lr).Value
        R1 = UBound(sArr, 1)
        C1 = UBound(sArr, 2)
        ReDim dArr(1 To R1, 1 To C1)
        For i = 4 To R1
            dic.Item(sArr(i, 1)) = i - 3
        Next i
        For i = 4 To C1
            dic.Item(sArr(1, i)) = i - 1
        Next i
    End With
    With Sheets("sl")
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        sArr = .Range("E4:I" & lr).Value
        For i = 1 To UBound(sArr)
             a = dic.Item(sArr(i, 1))
             b = dic.Item(sArr(i, 4))
             If a > 0 Then
                dArr(a, 1) = sArr(i, 2)
                dArr(a, 2) = sArr(i, 3)
             End If
             If a > 0 And b > 0 Then
                dArr(a, b) = dArr(a, b) + sArr(i, 5)
                dArr(a, C1) = dArr(a, C1) + sArr(i, 5)
             End If
        Next i
    End With
        Sheets("tonghop").Range("C4").Resize(R1, C1).Value = dArr
    Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Em thêm dữ liệu vào dòng có tô màu đỏ nó sẽ không hiện dữ liệu ạ
 

File đính kèm

  • báo cáo 01-2020 (1).xlsm
    31.2 KB · Đọc: 5
Upvote 0
HO VAN DUNG đã viết:
dạ, em thấy rồi ạ, cho em hỏi chút nữa là: trên sheet tổng hợp ở cột màu xanh C và D không tự động điền khi chạy code được không ạ, khi không có dữ liệu 1 trong 3 cột đó thì không hiện kết quả ạ
Nhấp chuột vào đây để mở rộng...
chưa hiểu ý bạn lắm, bạn nói rõ hơn được không? không có dữ liệu 1 trong 3 cột nào? của sheet nào?
 
Upvote 0
HO VAN DUNG đã viết:
em có ghi chú trong file nhờ a xem giùm ạ
Nhấp chuột vào đây để mở rộng...
Bạn thử xem
PHP: 
Sub sumifs()
    Dim dic As Object, sArr(), dArr()
    Dim i As Long, j As Long, lr As Long, Row As Long, Col As Long, R1 As Long, C1 As Long, a As Long, b As Long
    Dim TMP$
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("tonghop")
            lr = .Range("B" & Rows.Count).End(xlUp).Row
        sArr = .Range("B1:AI" & lr).Value
        R1 = UBound(sArr, 1)
        C1 = UBound(sArr, 2)
        ReDim dArr(1 To R1, 1 To C1)
            
        For i = 4 To R1
            TMP = sArr(i, 1) & sArr(i, 2) & sArr(i, 3)
            If Not dic.Exists(TMP) Then dic.Add TMP, i - 3
        Next i
        For i = 4 To C1
            dic.Add sArr(1, i), i - 3
        Next i
    End With
    With Sheets("sl")
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        sArr = .Range("E4:I" & lr).Value
        For i = 1 To UBound(sArr)
            TMP = sArr(i, 1) & sArr(i, 2) & sArr(i, 3)
             a = dic.Item(TMP)
             b = dic.Item(sArr(i, 4))
             If a > 0 And b > 0 Then
                dArr(a, b) = dArr(a, b) + sArr(i, 5)
                dArr(a, C1 - 2) = dArr(a, C1 - 2) + sArr(i, 5)
             End If
        Next i
    End With
        Sheets("tonghop").Range("E4").Resize(R1, C1 - 2).Value = dArr
    Set dic = Nothing
End Sub
 
Upvote 0
anhtuan2939 đã viết:
Bạn thử xem
PHP: 
Sub sumifs()
    Dim dic As Object, sArr(), dArr()
    Dim i As Long, j As Long, lr As Long, Row As Long, Col As Long, R1 As Long, C1 As Long, a As Long, b As Long
    Dim TMP$
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("tonghop")
            lr = .Range("B" & Rows.Count).End(xlUp).Row
        sArr = .Range("B1:AI" & lr).Value
        R1 = UBound(sArr, 1)
        C1 = UBound(sArr, 2)
        ReDim dArr(1 To R1, 1 To C1)
           
        For i = 4 To R1
            TMP = sArr(i, 1) & sArr(i, 2) & sArr(i, 3)
            If Not dic.Exists(TMP) Then dic.Add TMP, i - 3
        Next i
        For i = 4 To C1
            dic.Add sArr(1, i), i - 3
        Next i
    End With
    With Sheets("sl")
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        sArr = .Range("E4:I" & lr).Value
        For i = 1 To UBound(sArr)
            TMP = sArr(i, 1) & sArr(i, 2) & sArr(i, 3)
             a = dic.Item(TMP)
             b = dic.Item(sArr(i, 4))
             If a > 0 And b > 0 Then
                dArr(a, b) = dArr(a, b) + sArr(i, 5)
                dArr(a, C1 - 2) = dArr(a, C1 - 2) + sArr(i, 5)
             End If
        Next i
    End With
        Sheets("tonghop").Range("E4").Resize(R1, C1 - 2).Value = dArr
    Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
dạ, được rồi ạ, em cảm ơn anh ạ
 
Upvote 0
anhtuan2939 đã viết:
Bạn thử xem
PHP: 
Sub sumifs()
    Dim dic As Object, sArr(), dArr()
    Dim i As Long, j As Long, lr As Long, Row As Long, Col As Long, R1 As Long, C1 As Long, a As Long, b As Long
    Dim TMP$
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("tonghop")
            lr = .Range("B" & Rows.Count).End(xlUp).Row
        sArr = .Range("B1:AI" & lr).Value
        R1 = UBound(sArr, 1)
        C1 = UBound(sArr, 2)
        ReDim dArr(1 To R1, 1 To C1)
           
        For i = 4 To R1
            TMP = sArr(i, 1) & sArr(i, 2) & sArr(i, 3)
            If Not dic.Exists(TMP) Then dic.Add TMP, i - 3
        Next i
        For i = 4 To C1
            dic.Add sArr(1, i), i - 3
        Next i
    End With
    With Sheets("sl")
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        sArr = .Range("E4:I" & lr).Value
        For i = 1 To UBound(sArr)
            TMP = sArr(i, 1) & sArr(i, 2) & sArr(i, 3)
             a = dic.Item(TMP)
             b = dic.Item(sArr(i, 4))
             If a > 0 And b > 0 Then
                dArr(a, b) = dArr(a, b) + sArr(i, 5)
                dArr(a, C1 - 2) = dArr(a, C1 - 2) + sArr(i, 5)
             End If
        Next i
    End With
        Sheets("tonghop").Range("E4").Resize(R1, C1 - 2).Value = dArr
    Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
nhờ anh xem giùm em code của anh em ứng dụng vào file này không chạy được ạ, nhờ anh xem và sửa giùm em với ạ
 

File đính kèm

  • FROM .xlsb
    560.8 KB · Đọc: 4
Upvote 0
Xài đỡ cái này:
Mã: 
Sub TinhTong()
Dim lr&, i&, j&, k&, rng, arr(1 To 100000, 1 To 23), id As String
Dim dic As Object, key, s
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Chi_Tiet_nhap")
    lr = .Cells(Rows.Count, "E").End(xlUp).Row
    rng = .Range("E6:P" & lr).Value
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 2) & "|" & rng(i, 3) & "|" & rng(i, 12)
        If Not dic.exists(id) Then
            dic.Add id, IIf(IsEmpty(rng(i, 7)), 0, rng(i, 7)) & "|" & 0
        Else
            dic(id) = (Split(dic(id), "|")(0) + IIf(IsEmpty(rng(i, 7)), 0, rng(i, 7))) & "|" & 0
        End If
    Next
End With
With Sheets("Chi_Tiet_xuat")
    lr = .Cells(Rows.Count, "E").End(xlUp).Row
    rng = .Range("E6:P" & lr).Value
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 2) & "|" & rng(i, 3) & "|" & rng(i, 12)
        If Not dic.exists(id) Then
            dic.Add id, 0 & "|" & IIf(IsEmpty(rng(i, 8)), 0, rng(i, 8))
        Else
            dic(id) = Split(dic(id), "|")(0) & "|" & (Split(dic(id), "|")(1) + IIf(IsEmpty(rng(i, 8)), 0, rng(i, 8)))
        End If
    Next
End With
For Each key In dic.keys
        k = k + 1: s = Split(key & "|" & dic(key), "|")
        arr(k, 1) = k: arr(k, 3) = s(0): arr(k, 4) = s(1): arr(k, 5) = s(2)
        Select Case s(3)
            Case "BTP"
                arr(k, 15) = s(4): arr(k, 19) = s(5)
            Case "WAS"
                arr(k, 16) = s(4): arr(k, 23) = s(5)
            Case "HTA"
                arr(k, 17) = s(4)
            Case "TPA"
                arr(k, 18) = s(4): arr(k, 20) = s(5)
            Case "HUY"
                arr(k, 21) = s(5)
            Case "XLL"
                arr(k, 22) = s(5)
        End Select
Next
With Sheets("TONG_HOP")
    .Range("A5:W1000").ClearContents
    .Range("a5").Resize(k, 23).Value = arr
End With
End Sub
 

File đính kèm

  • FROM .xlsb
    562.9 KB · Đọc: 14
  • Yêu thích
Reactions: th7
Upvote 0
bebo021999 đã viết:
Xài đỡ cái này:
Mã: 
Sub TinhTong()
Dim lr&, i&, j&, k&, rng, arr(1 To 100000, 1 To 23), id As String
Dim dic As Object, key, s
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Chi_Tiet_nhap")
    lr = .Cells(Rows.Count, "E").End(xlUp).Row
    rng = .Range("E6:P" & lr).Value
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 2) & "|" & rng(i, 3) & "|" & rng(i, 12)
        If Not dic.exists(id) Then
            dic.Add id, IIf(IsEmpty(rng(i, 7)), 0, rng(i, 7)) & "|" & 0
        Else
            dic(id) = (Split(dic(id), "|")(0) + IIf(IsEmpty(rng(i, 7)), 0, rng(i, 7))) & "|" & 0
        End If
    Next
End With
With Sheets("Chi_Tiet_xuat")
    lr = .Cells(Rows.Count, "E").End(xlUp).Row
    rng = .Range("E6:P" & lr).Value
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 2) & "|" & rng(i, 3) & "|" & rng(i, 12)
        If Not dic.exists(id) Then
            dic.Add id, 0 & "|" & IIf(IsEmpty(rng(i, 8)), 0, rng(i, 8))
        Else
            dic(id) = Split(dic(id), "|")(0) & "|" & (Split(dic(id), "|")(1) + IIf(IsEmpty(rng(i, 8)), 0, rng(i, 8)))
        End If
    Next
End With
For Each key In dic.keys
        k = k + 1: s = Split(key & "|" & dic(key), "|")
        arr(k, 1) = k: arr(k, 3) = s(0): arr(k, 4) = s(1): arr(k, 5) = s(2)
        Select Case s(3)
            Case "BTP"
                arr(k, 15) = s(4): arr(k, 19) = s(5)
            Case "WAS"
                arr(k, 16) = s(4): arr(k, 23) = s(5)
            Case "HTA"
                arr(k, 17) = s(4)
            Case "TPA"
                arr(k, 18) = s(4): arr(k, 20) = s(5)
            Case "HUY"
                arr(k, 21) = s(5)
            Case "XLL"
                arr(k, 22) = s(5)
        End Select
Next
With Sheets("TONG_HOP")
    .Range("A5:W1000").ClearContents
    .Range("a5").Resize(k, 23).Value = arr
End With
End Sub
[/QUOTE]
Nhấp chuột vào đây để mở rộng...

bebo021999 đã viết:
Xài đỡ cái này:
Mã: 
Sub TinhTong()
Dim lr&, i&, j&, k&, rng, arr(1 To 100000, 1 To 23), id As String
Dim dic As Object, key, s
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Chi_Tiet_nhap")
    lr = .Cells(Rows.Count, "E").End(xlUp).Row
    rng = .Range("E6:P" & lr).Value
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 2) & "|" & rng(i, 3) & "|" & rng(i, 12)
        If Not dic.exists(id) Then
            dic.Add id, IIf(IsEmpty(rng(i, 7)), 0, rng(i, 7)) & "|" & 0
        Else
            dic(id) = (Split(dic(id), "|")(0) + IIf(IsEmpty(rng(i, 7)), 0, rng(i, 7))) & "|" & 0
        End If
    Next
End With
With Sheets("Chi_Tiet_xuat")
    lr = .Cells(Rows.Count, "E").End(xlUp).Row
    rng = .Range("E6:P" & lr).Value
    For i = 1 To UBound(rng)
        id = rng(i, 1) & "|" & rng(i, 2) & "|" & rng(i, 3) & "|" & rng(i, 12)
        If Not dic.exists(id) Then
            dic.Add id, 0 & "|" & IIf(IsEmpty(rng(i, 8)), 0, rng(i, 8))
        Else
            dic(id) = Split(dic(id), "|")(0) & "|" & (Split(dic(id), "|")(1) + IIf(IsEmpty(rng(i, 8)), 0, rng(i, 8)))
        End If
    Next
End With
For Each key In dic.keys
        k = k + 1: s = Split(key & "|" & dic(key), "|")
        arr(k, 1) = k: arr(k, 3) = s(0): arr(k, 4) = s(1): arr(k, 5) = s(2)
        Select Case s(3)
            Case "BTP"
                arr(k, 15) = s(4): arr(k, 19) = s(5)
            Case "WAS"
                arr(k, 16) = s(4): arr(k, 23) = s(5)
            Case "HTA"
                arr(k, 17) = s(4)
            Case "TPA"
                arr(k, 18) = s(4): arr(k, 20) = s(5)
            Case "HUY"
                arr(k, 21) = s(5)
            Case "XLL"
                arr(k, 22) = s(5)
        End Select
Next
With Sheets("TONG_HOP")
    .Range("A5:W1000").ClearContents
    .Range("a5").Resize(k, 23).Value = arr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
dạ, em cảm ơn bác nhiều ạ
 
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

K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
13
Đọc
214
ptm0412
ptm0412
Huy@@*
Giải đáp giùm em, cách khắc phục lỗi này trên VBA
2
Trả lời
28
Đọc
308
ptm0412
ptm0412
SA_DQ
Phẩu thuật Nụ cười lần 3 tại Huế.
    • Thích
Trả lời
0
Đọc
23
SA_DQ
SA_DQ
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
175
Đọc
9K
ongke0711
ongke0711
E
  • Question
Tạo bảng lọc theo điều kiện
Trả lời
7
Đọc
118
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
1
Đọc
52
BuiQuangThuan
B
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
44
Bobomkkk
B
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
93
Decepticon
D
N
cộng các dữ liệu không trùng nhau
Trả lời
12
Đọc
190
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
133
HieuCD
H
T
Trùng 2 lần: Tìm dữ liệu nhiều điều kiện
Trả lời
0
Đọc
80
Thulib
T
N
  • Question
Xin mã code ẩn hiện dòng theo điều kiện
Trả lời
10
Đọc
112
Nguyễn Diêu Hiền
N
N
Công thức tính số phù hợp với % mong muốn
Trả lời
9
Đọc
161
CHAOQUAY
C
B
Giúp em xử lý lỗi macro khi chạy VBA
2
Trả lời
21
Đọc
458
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
335
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
108
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
144
SA_DQ
SA_DQ
LuuAnh980
Từ "cân đối" trong tiếng Anh là gì?
2 3
Trả lời
44
Đọc
2K
VetMini
V
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