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

Liên hệ QC
queluatb

queluatb

Thành viên thường trực
Tham gia
17/1/11
Bài viết
345
Được thích
41
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
 

File đính kèm

  • FORM Z_2019 (lan_1).xlsb
    52.5 KB · Đọc: 25
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

  • FORM Z_2019 .xlsb
    90.4 KB · Đọc: 11
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
e cám ơn ah 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

ann266
Kế toán kho F&B
    • Cười
Trả lời
10
Đọc
107
ann266
ann266
V
  • Question
GIúp code xóa các tên mặt hàng trùng nhau, chỉ chừa lại tên cho dòng trên cùng
Trả lời
10
Đọc
279
Phan Thế Hiệp
Phan Thế Hiệp
hoanggiang1811
File excel bị nhảy trang in khi máy dùng màn hình CRT
Trả lời
6
Đọc
4K
pthau72
pthau72
T
Tổng hợp từ Sheet1 qua Sheet2
Trả lời
3
Đọc
55
hoangtuaotrang_hp_vn
H
T
Cần bạn viết phần mềm quản lý quán karaoke bằng excel
Trả lời
5
Đọc
126
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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