Tính tổng theo điều kiện

queluatb · 29/5/19

e có file đính kèm, trong file e sử dụng recod macro để tính tổng, các a, c giúp e xem thay thế bằng code để có thể tự động tính tổng với ạ, e cám ơn

queluatb · 5/6/19

HieuCD đã viết:

Viết lại code cho gọn hơn
Trong vùng cần tính hàm Sumifs, nhập ký tự bất kỳ với ký tự đầu khác dấu "=" hoặc bắt đầu bằng "=SumIfS(... " , code sẽ tự tính theo hàm SumIfS, các ô có công thức khác sẽ giữ nguyên công thức

Mã:

Sub SumIfVba()
  Dim sArr(), dArr(), Res(), SheetName(), Dic As Object, iKey, tmp
  Dim PX As String, fDay, eDay
  Dim n As Long, eRow As Long, sRow As Long, i As Long, ik As Long, j As Long, m As Long

  With Sheets("PSTP")
    eRow = .Range("A1000000").End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:L" & eRow).Value
  End With
  Set Dic = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  SheetName = Array("Zep", "Zoxi", "Zstd")
  For n = 0 To UBound(SheetName)
    With Sheets(SheetName(n))
      eRow = .Range("B1000000").End(xlUp).Row
      If eRow > 7 Then
        PX = .Range("C1")
        fDay = .Range("D2"): eDay = .Range("E2")
        dArr = .Range("B6:B" & eRow).Formula
        Res = .Range("E6:G" & eRow).Formula
        For i = 1 To UBound(Res)
          If Len(dArr(i, 1)) > 0 Then
            For j = 1 To 3
              tmp = Res(i, j)
              If Len(tmp) > 0 Then
                If InStr(1, tmp, "=SUMIFS") = 1 Or Mid(tmp, 1, 1) <> "=" Then
                  iKey = j & "#" & dArr(i, 1)
                  If Dic.exists(iKey) = False Then
                    Dic.Add iKey, i
                    Res(i, j) = 0
                  End If
                End If
              End If
            Next j
          End If
        Next i
      
        For i = 1 To UBound(sArr)
          If sArr(i, 4) = PX Then
            If sArr(i, 1) >= fDay Then
              If sArr(i, 1) <= eDay Then
                For j = 1 To 3
                  ik = Dic.Item(j & "#" & sArr(i, 6))
                  If ik > 0 Then
                    If j = 2 Then m = 12 Else m = j + 9
                    Res(ik, j) = Res(ik, j) + sArr(i, m)
                  End If
                Next j
              End If
            End If
          End If
        Next i
      End If
      Dic.RemoveAll
      .Range("E6:G" & eRow) = Res
    End With
  Next n
  Application.ScreenUpdating = True
  MsgBox ("Da khoi tao lai Gia tri Ham SumIfS")
End Sub

a cho e hỏi có cách nào chỉ thay đổi giá trị ngày tháng thì hàm tự tính như khi đặt công thức excel thông thường không a

HieuCD · 5/6/19

queluatb đã viết:
a cho e hỏi có cách nào chỉ thay đổi giá trị ngày tháng thì hàm tự tính như khi đặt công thức excel thông thường không a

Copy code sự kiện vào các sheet

Mã:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address(0, 0) = "D2" Or Target.Address(0, 0) = "E2" Then
    If TypeName(Target.Value) <> "Date" Then
      MsgBox ("Cell " & Target.Address(0, 0) & ": Khong dung dang ngay thang"): Exit Sub
    End If
    If TypeName(Target.Value) <> "Date" Then
      MsgBox ("Cell " & Target.Address(0, 0) & ": Khong dung dang ngay thang"): Exit Sub
    End If
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Call SumIfS_Vba(Range("D2").Value, Range("E2").Value, ActiveSheet.Name)
    Application.ScreenUpdating = True
    Application.EnableEvents = True
  End If
End Sub

Khi thời gian thay đổi sẽ chạy code tính tổng

Mã:

Option Explicit
Sub SumIfS_Vba(ByVal fDay As Date, ByVal eDay As Date, ByVal shName As String)
  Dim sArr(), dArr(), Res(), Dic As Object
  Dim PX As String, iKey, tmp
  Dim n As Long, eRow As Long, i As Long, ik As Long, j As Long, m As Long
 
  With Sheets("PSTP")
    eRow = .Range("A1000000").End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:L" & eRow).Value
  End With
 
  With Sheets(shName)
    eRow = .Range("B1000000").End(xlUp).Row
    If eRow > 7 Then
      Set Dic = CreateObject("Scripting.Dictionary")
      PX = .Range("C1")
      dArr = .Range("B6:B" & eRow).Formula
      Res = .Range("E6:G" & eRow).Formula
      For i = 1 To UBound(Res)
        If Len(dArr(i, 1)) > 0 Then
          For j = 1 To 3
            tmp = Res(i, j)
            If Len(tmp) > 0 Then
              If InStr(1, tmp, "=SUMIFS") = 1 Or Mid(tmp, 1, 1) <> "=" Then
                iKey = j & "#" & dArr(i, 1)
                If Dic.exists(iKey) = False Then
                  Dic.Add iKey, i
                  Res(i, j) = 0
                End If
              End If
            End If
          Next j
        End If
      Next i
        
      For i = 1 To UBound(sArr)
        If sArr(i, 4) = PX Then
          If sArr(i, 1) >= fDay Then
            If sArr(i, 1) <= eDay Then
              For j = 1 To 3
                ik = Dic.Item(j & "#" & sArr(i, 6))
                If ik > 0 Then
                  If j = 2 Then m = 12 Else m = j + 9
                  Res(ik, j) = Res(ik, j) + sArr(i, m)
                End If
              Next j
            End If
          End If
        End If
      Next i
      Set Dic = Nothing
      .Range("E6:G" & eRow) = Res
    End If
  End With
End Sub

queluatb · 6/6/19

HieuCD đã viết:

Copy code sự kiện vào các sheet

Mã:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address(0, 0) = "D2" Or Target.Address(0, 0) = "E2" Then
    If TypeName(Target.Value) <> "Date" Then
      MsgBox ("Cell " & Target.Address(0, 0) & ": Khong dung dang ngay thang"): Exit Sub
    End If
    If TypeName(Target.Value) <> "Date" Then
      MsgBox ("Cell " & Target.Address(0, 0) & ": Khong dung dang ngay thang"): Exit Sub
    End If
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Call SumIfS_Vba(Range("D2").Value, Range("E2").Value, ActiveSheet.Name)
    Application.ScreenUpdating = True
    Application.EnableEvents = True
  End If
End Sub

Khi thời gian thay đổi sẽ chạy code tính tổng

Mã:

Option Explicit
Sub SumIfS_Vba(ByVal fDay As Date, ByVal eDay As Date, ByVal shName As String)
  Dim sArr(), dArr(), Res(), Dic As Object
  Dim PX As String, iKey, tmp
  Dim n As Long, eRow As Long, i As Long, ik As Long, j As Long, m As Long

  With Sheets("PSTP")
    eRow = .Range("A1000000").End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:L" & eRow).Value
  End With

  With Sheets(shName)
    eRow = .Range("B1000000").End(xlUp).Row
    If eRow > 7 Then
      Set Dic = CreateObject("Scripting.Dictionary")
      PX = .Range("C1")
      dArr = .Range("B6:B" & eRow).Formula
      Res = .Range("E6:G" & eRow).Formula
      For i = 1 To UBound(Res)
        If Len(dArr(i, 1)) > 0 Then
          For j = 1 To 3
            tmp = Res(i, j)
            If Len(tmp) > 0 Then
              If InStr(1, tmp, "=SUMIFS") = 1 Or Mid(tmp, 1, 1) <> "=" Then
                iKey = j & "#" & dArr(i, 1)
                If Dic.exists(iKey) = False Then
                  Dic.Add iKey, i
                  Res(i, j) = 0
                End If
              End If
            End If
          Next j
        End If
      Next i
       
      For i = 1 To UBound(sArr)
        If sArr(i, 4) = PX Then
          If sArr(i, 1) >= fDay Then
            If sArr(i, 1) <= eDay Then
              For j = 1 To 3
                ik = Dic.Item(j & "#" & sArr(i, 6))
                If ik > 0 Then
                  If j = 2 Then m = 12 Else m = j + 9
                  Res(ik, j) = Res(ik, j) + sArr(i, m)
                End If
              Next j
            End If
          End If
        End If
      Next i
      Set Dic = Nothing
      .Range("E6:G" & eRow) = Res
    End If
  End With
End Sub

e cám ơn ah nhiều

Tính tổng theo điều kiện

queluatb

Thành viên thường trực

File đính kèm

queluatb

Thành viên thường trực

HieuCD

Chuyên gia GPE

File đính kèm

queluatb

Thành viên thường trực

Bài viết mới nhất

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

Đếm ngược thời gian