Code VBA thay thế hàm SUMIFS (1 người xem)

[vantuan2939]

Chào cả nhà, em có file như dưới, nhờ các cao thủ viết giùm e code thay thế hàm sumifs để sheet!KETQUA (phần màu xám) có được kết quả như sheet!DL_NGUON. E cám ơn cả nhà!!!

 

[HieuCD]

Chào cả nhà, em có file như dưới, nhờ các cao thủ viết giùm e code thay thế hàm sumifs để sheet!KETQUA (phần màu xám) có được kết quả như sheet!DL_NGUON. E cám ơn cả nhà!!!

Chạy code

Sub TongHop()
  Dim aData(), aTen(), aNgay(), Res()
  Dim sRow&, sRow2&, sCol&, i&, ik&, j&, jk&
  With Sheets("DL_NGUON")
    aData = .Range("A2", .Range("G" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("KET_QUA")
    aTen = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Value
    aNgay = .Range("C2:T2").Value
  End With
  sRow = UBound(aTen):  sCol = UBound(aNgay, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Len(aTen(i, 1)) Then .Item(aTen(i, 1)) = i
    Next i
    For j = 1 To sCol
      If Len(aNgay(1, j)) Then .Item(aNgay(1, j)) = j
    Next j
    sRow2 = UBound(aData)
    For i = 1 To sRow2
      ik = .Item(aData(i, 1))
      jk = .Item(aData(i, 2))
      If ik > 0 And jk > 0 Then Res(ik, jk) = Res(ik, jk) + aData(i, 7)
    Next i
  End With
  Sheets("KET_QUA").Range("C3").Resize(sRow, sCol).Value = Res
End Sub

 

[vantuan2939]

Chạy code

Sub TongHop()
  Dim aData(), aTen(), aNgay(), Res()
  Dim sRow&, sRow2&, sCol&, i&, ik&, j&, jk&
  With Sheets("DL_NGUON")
    aData = .Range("A2", .Range("G" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("KET_QUA")
    aTen = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Value
    aNgay = .Range("C2:T2").Value
  End With
  sRow = UBound(aTen):  sCol = UBound(aNgay, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Len(aTen(i, 1)) Then .Item(aTen(i, 1)) = i
    Next i
    For j = 1 To sCol
      If Len(aNgay(1, j)) Then .Item(aNgay(1, j)) = j
    Next j
    sRow2 = UBound(aData)
    For i = 1 To sRow2
      ik = .Item(aData(i, 1))
      jk = .Item(aData(i, 2))
      If ik > 0 And jk > 0 Then Res(ik, jk) = Res(ik, jk) + aData(i, 7)
    Next i
  End With
  Sheets("KET_QUA").Range("C3").Resize(sRow, sCol).Value = Res
End Sub

cám ơn bác, đúng với ý của e luôn, sau khi chỉnh sửa 1 vài vị trí là có thể sử dụng vào file của e rồi. 1 lần nữa cám ơn bác nhiều!!!!

 

[vantuan2939]

Chạy code

Sub TongHop()
  Dim aData(), aTen(), aNgay(), Res()
  Dim sRow&, sRow2&, sCol&, i&, ik&, j&, jk&
  With Sheets("DL_NGUON")
    aData = .Range("A2", .Range("G" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("KET_QUA")
    aTen = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Value
    aNgay = .Range("C2:T2").Value
  End With
  sRow = UBound(aTen):  sCol = UBound(aNgay, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Len(aTen(i, 1)) Then .Item(aTen(i, 1)) = i
    Next i
    For j = 1 To sCol
      If Len(aNgay(1, j)) Then .Item(aNgay(1, j)) = j
    Next j
    sRow2 = UBound(aData)
    For i = 1 To sRow2
      ik = .Item(aData(i, 1))
      jk = .Item(aData(i, 2))
      If ik > 0 And jk > 0 Then Res(ik, jk) = Res(ik, jk) + aData(i, 7)
    Next i
  End With
  Sheets("KET_QUA").Range("C3").Resize(sRow, sCol).Value = Res
End Sub

Bác cho e hỏi tí, làm thế nào để nó không phân biệt chữ thường và chữ in hoa, vì nếu ở sheet nguồn là chữ in, mà bên sheet kết quả là chữ thường thì nó sẽ không ra kết quả. Nhờ bác thêm vào cho đoạn code không phân biệt chữ thường và chữ in được không ạ!!! E cám ơn bác!

 

[snow25]

Bác cho e hỏi tí, làm thế nào để nó không phân biệt chữ thường và chữ in hoa, vì nếu ở sheet nguồn là chữ in, mà bên sheet kết quả là chữ thường thì nó sẽ không ra kết quả. Nhờ bác thêm vào cho đoạn code không phân biệt chữ thường và chữ in được không ạ!!! E cám ơn bác!

Bạn thử.Mình không xem code nhé.Chỉ thêm 1 chút.

Sub TongHop()
  Dim aData(), aTen(), aNgay(), Res()
  Dim sRow&, sRow2&, sCol&, i&, ik&, j&, jk&
  With Sheets("DL_NGUON")
    aData = .Range("A2", .Range("G" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("KET_QUA")
    aTen = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Value
    aNgay = .Range("C2:T2").Value
  End With
  sRow = UBound(aTen):  sCol = UBound(aNgay, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To sRow
      If Len(aTen(i, 1)) Then .Item(aTen(i, 1)) = i
    Next i
    For j = 1 To sCol
      If Len(aNgay(1, j)) Then .Item(aNgay(1, j)) = j
    Next j
    sRow2 = UBound(aData)
    For i = 1 To sRow2
      ik = .Item(aData(i, 1))
      jk = .Item(aData(i, 2))
      If ik > 0 And jk > 0 Then Res(ik, jk) = Res(ik, jk) + aData(i, 7)
    Next i
  End With
  Sheets("KET_QUA").Range("C3").Resize(sRow, sCol).Value = Res
End Sub

 

[vantuan2939]

Bạn thử.Mình không xem code nhé.Chỉ thêm 1 chút.

Sub TongHop()
  Dim aData(), aTen(), aNgay(), Res()
  Dim sRow&, sRow2&, sCol&, i&, ik&, j&, jk&
  With Sheets("DL_NGUON")
    aData = .Range("A2", .Range("G" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("KET_QUA")
    aTen = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Value
    aNgay = .Range("C2:T2").Value
  End With
  sRow = UBound(aTen):  sCol = UBound(aNgay, 2)
  ReDim Res(1 To sRow, 1 To sCol)
  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To sRow
      If Len(aTen(i, 1)) Then .Item(aTen(i, 1)) = i
    Next i
    For j = 1 To sCol
      If Len(aNgay(1, j)) Then .Item(aNgay(1, j)) = j
    Next j
    sRow2 = UBound(aData)
    For i = 1 To sRow2
      ik = .Item(aData(i, 1))
      jk = .Item(aData(i, 2))
      If ik > 0 And jk > 0 Then Res(ik, jk) = Res(ik, jk) + aData(i, 7)
    Next i
  End With
  Sheets("KET_QUA").Range("C3").Resize(sRow, sCol).Value = Res
End Sub

Mình đã thử và đã thành công. Cám ơn bạn nhé！