Code tổng hợp thay hàm sumif thiếu kết quả (1 người xem)

[shnhatha221108]

Nhờ anh @HieuCD và anh chị em xem giúp.
Em có xem code của anh @HieuCD về tổng hợp dữ liệu thay hàm sumif.Khi áp dung cho một mảng dữ liệu thì dòng cuối không cho kết quả
Vậy em muốn nhờ anh @HieuCD và anh chị em diễn đàn chỉ bảo giúp sai ở đậu ạ?

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 
    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

 

[Maika8008]

Xem lại trước khi ghi kết quả lên sheet thì i - fR + 1 là bao nhiêu

 

[HieuCD]

Nhờ anh @HieuCD và anh chị em xem giúp.
Em có xem code của anh @HieuCD về tổng hợp dữ liệu thay hàm sumif.Khi áp dung cho một mảng dữ liệu thì dòng cuối không cho kết quả
Vậy em muốn nhờ anh @HieuCD và anh chị em diễn đàn chỉ bảo giúp sai ở đậu ạ?
View attachment 294666

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
    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

Code dùng cho dữ liệu dạng khác, bài nầy đơn giản nên viết lại bỏ bớt các if else

 

[shnhatha221108]

Code dùng cho dữ liệu dạng khác, bài nầy đơn giản nên viết lại bỏ bớt các if else

Nếu chỉ áp dụng cho 1 mảng như file đính kèm nhờ anh chỉ bảo và sửa giúp ạ

 

[HieuCD]

Nếu chỉ áp dụng cho 1 mảng như file đính kèm nhờ anh chỉ bảo và sửa giúp ạ

Xem code . . .

Sub XYZ()
  Dim arr(), aNgay(), aHang(), res(), Dic As Object, key$
  Dim i&, j&, sRow&, sCol&
 
  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheets("DATA")
    If .AutoFilterMode Then .AutoFilter.ShowAllData
    arr = .Range("I3", .Range("AD" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("THUC TE")
    If .AutoFilterMode Then .AutoFilter.ShowAllData
    aNgay = .Range("E3", .Range("AAA3").End(xlToLeft)).Value
    aHang = .Range("A5", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 15)
    Dic.Item(key) = Dic.Item(key) + arr(i, 22)
  Next i
 
  sRow = UBound(aHang)
  sCol = UBound(aNgay, 2)
  ReDim res(1 To sRow, 1 To sCol)
  For i = 1 To sRow
    For j = 1 To sCol
      res(i, j) = Dic(aHang(i, 1) & "|" & aNgay(1, j))
    Next j
  Next i
  Sheets("THUC TE").Range("E5").Resize(sRow, sCol) = res
  Set Dic = Nothing
End Sub

 

[shnhatha221108]

Xem code . . .

Sub XYZ()
  Dim arr(), aNgay(), aHang(), res(), Dic As Object, key$
  Dim i&, j&, sRow&, sCol&
 
  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheets("DATA")
    If .AutoFilterMode Then .AutoFilter.ShowAllData
    arr = .Range("I3", .Range("AD" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("THUC TE")
    If .AutoFilterMode Then .AutoFilter.ShowAllData
    aNgay = .Range("E3", .Range("AAA3").End(xlToLeft)).Value
    aHang = .Range("A5", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 15)
    Dic.Item(key) = Dic.Item(key) + arr(i, 22)
  Next i
 
  sRow = UBound(aHang)
  sCol = UBound(aNgay, 2)
  ReDim res(1 To sRow, 1 To sCol)
  For i = 1 To sRow
    For j = 1 To sCol
      res(i, j) = Dic(aHang(i, 1) & "|" & aNgay(1, j))
    Next j
  Next i
  Sheets("THUC TE").Range("E5").Resize(sRow, sCol) = res
  Set Dic = Nothing
End Sub

Cảm ơn anh rất nhiều đã giup em áp dụng được đoạn code trên cho công việc của mình
Chúc anh có ngày nghỉ vui vẻ