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
queluatb đã viết:
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
Nhấp chuột vào đây để mở rộng...
Làm thử cho sheet Zep
Mã: 
Option Explicit

Sub TongHopKinhPhi()
Dim Data
Dim Zep
Dim PhanXuong As String
Dim DoiTuong As String
Dim Mang
Dim NgayDau, Ngaycuoi
Dim i, k
With Sheets("DATA")
    i = .Range("A1000000").End(xlUp).Row
    Data = .Range("A5", "M" & i)
End With
With Sheets("Zep")
    i = .Range("D1000000").End(xlUp).Row
    Zep = .Range("A5", "G" & i)
    PhanXuong = .Range("D1")
    DoiTuong = .Range("C1")
    NgayDau = .Range("D2")
    Ngaycuoi = .Range("E2")
End With
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Data)
        If Data(i, 1) >= NgayDau And Data(i, 1) <= Ngaycuoi And Data(i, 4) = DoiTuong And Data(i, 5) = PhanXuong Then
            If .exists(Data(i, 6)) = False Then
                .Item(Data(i, 6)) = Array(Data(i, 9), Data(i, 10), Data(i, 11))
            Else
                Mang = .Item(Data(i, 6))
                Mang(0) = Mang(0) + Data(i, 9)
                Mang(1) = Data(i, 10)
                Mang(2) = Mang(2) + Data(i, 11)
                .Item(Data(i, 6)) = Mang
            End If
        End If
    Next i
    For i = 2 To UBound(Zep)
        If Zep(i, 2) <> "" Then
            If .exists(Zep(i, 2)) = True Then
                Zep(i, 5) = .Item(Zep(i, 2))(0)
                Zep(i, 7) = .Item(Zep(i, 2))(2)
            End If
        End If
    Next i
End With
For i = UBound(Zep) To 2 Step -1
    If Zep(i, 1) = "" Then
        If Zep(i, 2) <> "" Then k = k + Zep(i, 7)
    Else
        If Zep(i, 2) = "" Then
            Zep(i, 7) = k
            k = 0
        End If
    End If
Next i
With Sheets("Zep")
    .Range("A5").Resize(UBound(Zep), UBound(Zep, 2)).ClearContents
    .Range("A5").Resize(UBound(Zep), UBound(Zep, 2)) = Zep
End With
End Sub
 
Upvote 0
CHAOQUAY đã viết:
Làm thử cho sheet Zep
Mã: 
Option Explicit

Sub TongHopKinhPhi()
Dim Data
Dim Zep
Dim PhanXuong As String
Dim DoiTuong As String
Dim Mang
Dim NgayDau, Ngaycuoi
Dim i, k
With Sheets("DATA")
    i = .Range("A1000000").End(xlUp).Row
    Data = .Range("A5", "M" & i)
End With
With Sheets("Zep")
    i = .Range("D1000000").End(xlUp).Row
    Zep = .Range("A5", "G" & i)
    PhanXuong = .Range("D1")
    DoiTuong = .Range("C1")
    NgayDau = .Range("D2")
    Ngaycuoi = .Range("E2")
End With
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Data)
        If Data(i, 1) >= NgayDau And Data(i, 1) <= Ngaycuoi And Data(i, 4) = DoiTuong And Data(i, 5) = PhanXuong Then
            If .exists(Data(i, 6)) = False Then
                .Item(Data(i, 6)) = Array(Data(i, 9), Data(i, 10), Data(i, 11))
            Else
                Mang = .Item(Data(i, 6))
                Mang(0) = Mang(0) + Data(i, 9)
                Mang(1) = Data(i, 10)
                Mang(2) = Mang(2) + Data(i, 11)
                .Item(Data(i, 6)) = Mang
            End If
        End If
    Next i
    For i = 2 To UBound(Zep)
        If Zep(i, 2) <> "" Then
            If .exists(Zep(i, 2)) = True Then
                Zep(i, 5) = .Item(Zep(i, 2))(0)
                Zep(i, 7) = .Item(Zep(i, 2))(2)
            End If
        End If
    Next i
End With
For i = UBound(Zep) To 2 Step -1
    If Zep(i, 1) = "" Then
        If Zep(i, 2) <> "" Then k = k + Zep(i, 7)
    Else
        If Zep(i, 2) = "" Then
            Zep(i, 7) = k
            k = 0
        End If
    End If
Next i
With Sheets("Zep")
    .Range("A5").Resize(UBound(Zep), UBound(Zep, 2)).ClearContents
    .Range("A5").Resize(UBound(Zep), UBound(Zep, 2)) = Zep
End With
End Sub
Nhấp chuột vào đây để mở rộng...
e cám ơn a, e làm vào file có điều gì chưa hiểu mong ah chỉ giúp thêm
 
Upvote 0
CHAOQUAY đã viết:
Làm thử cho sheet Zep
Mã: 
Option Explicit

Sub TongHopKinhPhi()
Dim Data
Dim Zep
Dim PhanXuong As String
Dim DoiTuong As String
Dim Mang
Dim NgayDau, Ngaycuoi
Dim i, k
With Sheets("DATA")
    i = .Range("A1000000").End(xlUp).Row
    Data = .Range("A5", "M" & i)
End With
With Sheets("Zep")
    i = .Range("D1000000").End(xlUp).Row
    Zep = .Range("A5", "G" & i)
    PhanXuong = .Range("D1")
    DoiTuong = .Range("C1")
    NgayDau = .Range("D2")
    Ngaycuoi = .Range("E2")
End With
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Data)
        If Data(i, 1) >= NgayDau And Data(i, 1) <= Ngaycuoi And Data(i, 4) = DoiTuong And Data(i, 5) = PhanXuong Then
            If .exists(Data(i, 6)) = False Then
                .Item(Data(i, 6)) = Array(Data(i, 9), Data(i, 10), Data(i, 11))
            Else
                Mang = .Item(Data(i, 6))
                Mang(0) = Mang(0) + Data(i, 9)
                Mang(1) = Data(i, 10)
                Mang(2) = Mang(2) + Data(i, 11)
                .Item(Data(i, 6)) = Mang
            End If
        End If
    Next i
    For i = 2 To UBound(Zep)
        If Zep(i, 2) <> "" Then
            If .exists(Zep(i, 2)) = True Then
                Zep(i, 5) = .Item(Zep(i, 2))(0)
                Zep(i, 7) = .Item(Zep(i, 2))(2)
            End If
        End If
    Next i
End With
For i = UBound(Zep) To 2 Step -1
    If Zep(i, 1) = "" Then
        If Zep(i, 2) <> "" Then k = k + Zep(i, 7)
    Else
        If Zep(i, 2) = "" Then
            Zep(i, 7) = k
            k = 0
        End If
    End If
Next i
With Sheets("Zep")
    .Range("A5").Resize(UBound(Zep), UBound(Zep, 2)).ClearContents
    .Range("A5").Resize(UBound(Zep), UBound(Zep, 2)) = Zep
End With
End Sub
Nhấp chuột vào đây để mở rộng...
e đã gán code cho file nhưng k cho ra được kết quả, e gửi file đây a xem lại giúp
 

File đính kèm

  • FORM Z_2019 (lan_1).xlsb
    54 KB · Đọc: 8
Upvote 0
queluatb đã viết:
e đã gán code cho file nhưng k cho ra được kết quả, e gửi file đây a xem lại giúp
Nhấp chuột vào đây để mở rộng...
e thấy ở đây là cột mã phí của e bên sheet "DATA" thì anh đang thay bằng DoiTuong và PhanXuong = .Range("C1") chỗ này đang bị nhầm một chút, a xem và sửa lại giúp e với
 
Upvote 0
queluatb đã viết:
e đã gán code cho file nhưng k cho ra được kết quả, e gửi file đây a xem lại giúp
Nhấp chuột vào đây để mở rộng...
Bạn thay câu lệnh trên bang cau dưoi là ok
Mã: 
If Data(i, 1) >= NgayDau And Data(i, 1) <= Ngaycuoi And Data(i, 4) = DoiTuong And Data(i, 5) = PhanXuong Then
Mã: 
If Data(i, 1) >= NgayDau And Data(i, 1) <= Ngaycuoi And Data(i, 4) = DoiTuong And UCase(Data(i, 5)) = PhanXuong Then
Bài đã được tự động gộp:

queluatb đã viết:
e thấy ở đây là cột mã phí của e bên sheet "DATA" thì anh đang thay bằng DoiTuong và PhanXuong = .Range("C1") chỗ này đang bị nhầm một chút, a xem và sửa lại giúp e với
Nhấp chuột vào đây để mở rộng...
DoiTuong="PXE"
PhanXuong=D1 =>"PHÂN XƯỞNG ÉP ĐÙN"
Mã phí là Data(i, 6)
Có lẽ là không nhầm đâu bạn.
Bạn kiểm tra lại kết quả bằng công thức xem sao
 
Lần chỉnh sửa cuối:
Upvote 0
Em nhờ mọi người giúp e file này với ạ
 

File đính kèm

  • Book3.xlsx
    30.9 KB · Đọc: 6
Upvote 0
CHAOQUAY đã viết:
Bạn thay câu lệnh trên bang cau dưoi là ok
Mã: 
If Data(i, 1) >= NgayDau And Data(i, 1) <= Ngaycuoi And Data(i, 4) = DoiTuong And Data(i, 5) = PhanXuong Then
Mã: 
If Data(i, 1) >= NgayDau And Data(i, 1) <= Ngaycuoi And Data(i, 4) = DoiTuong And UCase(Data(i, 5)) = PhanXuong Then
Bài đã được tự động gộp:


DoiTuong="PXE"
PhanXuong=D1 =>"PHÂN XƯỞNG ÉP ĐÙN"
Mã phí là Data(i, 6)
Có lẽ là không nhầm đâu bạn.
Bạn kiểm tra lại kết quả bằng công thức xem sao
Nhấp chuột vào đây để mở rộng...
Dim PhanXuong As String phần này khai báo cho mã phân xưởng
Dim DoiTuong As String phần này e k hiểu hoàn toàn sao lại lấy "PHÂN XƯỞNG ÉP"
Dim Mang


PhanXuong = .Range("D1")
DoiTuong = .Range("C1")

a làm ơn giải thích giúp cho e hiểu với ah
 
Lần chỉnh sửa cuối:
Upvote 0
queluatb đã viết:
Dim PhanXuong As String phần này khai báo cho mã phân xưởng
Dim DoiTuong As String phần này e k hiểu hoàn toàn sao lại lấy "PHÂN XƯỞNG ÉP"
Dim Mang


PhanXuong = .Range("D1")
DoiTuong = .Range("C1")

a làm ơn giải thích giúp cho e hiểu với ah
Nhấp chuột vào đây để mở rộng...
Việc so sánh tên phân xưởng có lẽ bị thừa vì "đối tượng" đã đại diện cho tên phân xưởng.
Nguyên nhân vì ban đầu đọc bài nghĩ là cột "đối tượng" & cột "tên đối tượng" không liên quan gì với nhau.
Giờ bạn có thể bỏ điều kiện so sánh tên phân xưởng sẽ vẫn có kết quả đúng.
Bạn sửa như bên dưới rồi kiểm tra lại code
Mã: 
'If Data(i, 1) >= NgayDau And Data(i, 1) <= Ngaycuoi And Data(i, 4) = DoiTuong And UCase(Data(i, 5)) = PhanXuong Then
If Data(i, 1) >= NgayDau And Data(i, 1) <= Ngaycuoi And Data(i, 4) = DoiTuong Then
 
Upvote 0
A cho e hỏi là Câu lệnh này là tìm dòng cuối trong một cột đúng k ah
'i = .Range("A1000000").End(xlUp).Row
 
Upvote 0
queluatb đã viết:
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
Nhấp chuột vào đây để mở rộng...
Chạy thử code
Mã: 
Sub GPE()
  Dim sArr(), dArr(), Res(), SheetName(), Dic As Object, iKey
  Dim PX As String, fDay, eDay
  Dim n As Long, eRow As Long, sRow As Long, i As Long, ik As Long
  Dim Gt As Double, tGt As Double
 
  With Sheets("DATA")
    eRow = .Range("A1000000").End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:M" & eRow).Value
  End With
  Set Dic = CreateObject("Scripting.Dictionary")
 
  SheetName = Array("Zep", "Zoxi")
  For n = 0 To UBound(SheetName)
    With Sheets(SheetName(n))
      PX = .Range("C1")
      fDay = .Range("D2"): eDay = .Range("E2")
      eRow = .Range("B1000000").End(xlUp).Row
    End With
    If eRow > 7 Then
      dArr = Sheets(SheetName(n)).Range("A6:C" & eRow).Value
      sRow = UBound(dArr)
      ReDim Res(1 To sRow, 1 To 3)
      For i = 1 To sRow
        iKey = dArr(i, 2)
        If Len(iKey) > 0 Then
          Dic.Item(iKey) = i
        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
              ik = Dic.Item(sArr(i, 6))
              If ik > 0 Then
                If Len(sArr(i, 9)) > 0 Then Res(ik, 1) = Res(ik, 1) + sArr(i, 9)
                If Len(sArr(i, 11)) > 0 Then Res(ik, 3) = Res(ik, 3) + sArr(i, 11)
              End If
            End If
          End If
        End If
      Next i
    End If
    
    tGt = 0
    For i = sRow To 2 Step -1
      If Len(dArr(i, 2)) > 0 Then
        If Len(Res(i, 1)) > 0 And Len(Res(i, 3)) > 0 Then Res(i, 2) = Res(i, 3) / Res(i, 1)
        Gt = Gt + Res(i, 3)
        tGt = tGt + Res(i, 3)
      ElseIf Len(dArr(i, 1)) > 0 Then
        Res(i, 3) = Gt
        Gt = 0
      End If
    Next i
    Res(1, 3) = tGt
    Sheets(SheetName(n)).Range("E6:G" & eRow) = Res
    Dic.RemoveAll
  Next n
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy thử code
Mã: 
Sub GPE()
  Dim sArr(), dArr(), Res(), SheetName(), Dic As Object, iKey
  Dim PX As String, fDay, eDay
  Dim n As Long, eRow As Long, sRow As Long, i As Long, ik As Long
  Dim Gt As Double, tGt As Double

  With Sheets("DATA")
    eRow = .Range("A1000000").End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:M" & eRow).Value
  End With
  Set Dic = CreateObject("Scripting.Dictionary")

  SheetName = Array("Zep", "Zoxi")
  For n = 0 To UBound(SheetName)
    With Sheets(SheetName(n))
      PX = .Range("C1")
      fDay = .Range("D2"): eDay = .Range("E2")
      eRow = .Range("B1000000").End(xlUp).Row
    End With
    If eRow > 7 Then
      dArr = Sheets(SheetName(n)).Range("A6:C" & eRow).Value
      sRow = UBound(dArr)
      ReDim Res(1 To sRow, 1 To 3)
      For i = 1 To sRow
        iKey = dArr(i, 2)
        If Len(iKey) > 0 Then
          Dic.Item(iKey) = i
        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
              ik = Dic.Item(sArr(i, 6))
              If ik > 0 Then
                If Len(sArr(i, 9)) > 0 Then Res(ik, 1) = Res(ik, 1) + sArr(i, 9)
                If Len(sArr(i, 11)) > 0 Then Res(ik, 3) = Res(ik, 3) + sArr(i, 11)
              End If
            End If
          End If
        End If
      Next i
    End If
   
    tGt = 0
    For i = sRow To 2 Step -1
      If Len(dArr(i, 2)) > 0 Then
        If Len(Res(i, 1)) > 0 And Len(Res(i, 3)) > 0 Then Res(i, 2) = Res(i, 3) / Res(i, 1)
        Gt = Gt + Res(i, 3)
        tGt = tGt + Res(i, 3)
      ElseIf Len(dArr(i, 1)) > 0 Then
        Res(i, 3) = Gt
        Gt = 0
      End If
    Next i
    Res(1, 3) = tGt
    Sheets(SheetName(n)).Range("E6:G" & eRow) = Res
    Dic.RemoveAll
  Next n
End Sub
Nhấp chuột vào đây để mở rộng...
e cám ơn ạ, e xem và có chỗ nào chưa hiểu mong a hướng dẫn và giải thích giúp ạ
 
Upvote 0
HieuCD đã viết:
Chạy thử code
Mã: 
Sub GPE()
  Dim sArr(), dArr(), Res(), SheetName(), Dic As Object, iKey
  Dim PX As String, fDay, eDay
  Dim n As Long, eRow As Long, sRow As Long, i As Long, ik As Long
  Dim Gt As Double, tGt As Double

  With Sheets("DATA")
    eRow = .Range("A1000000").End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:M" & eRow).Value
  End With
  Set Dic = CreateObject("Scripting.Dictionary")

  SheetName = Array("Zep", "Zoxi")
  For n = 0 To UBound(SheetName)
    With Sheets(SheetName(n))
      PX = .Range("C1")
      fDay = .Range("D2"): eDay = .Range("E2")
      eRow = .Range("B1000000").End(xlUp).Row
    End With
    If eRow > 7 Then
      dArr = Sheets(SheetName(n)).Range("A6:C" & eRow).Value
      sRow = UBound(dArr)
      ReDim Res(1 To sRow, 1 To 3)
      For i = 1 To sRow
        iKey = dArr(i, 2)
        If Len(iKey) > 0 Then
          Dic.Item(iKey) = i
        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
              ik = Dic.Item(sArr(i, 6))
              If ik > 0 Then
                If Len(sArr(i, 9)) > 0 Then Res(ik, 1) = Res(ik, 1) + sArr(i, 9)
                If Len(sArr(i, 11)) > 0 Then Res(ik, 3) = Res(ik, 3) + sArr(i, 11)
              End If
            End If
          End If
        End If
      Next i
    End If
  
    tGt = 0
    For i = sRow To 2 Step -1
      If Len(dArr(i, 2)) > 0 Then
        If Len(Res(i, 1)) > 0 And Len(Res(i, 3)) > 0 Then Res(i, 2) = Res(i, 3) / Res(i, 1)
        Gt = Gt + Res(i, 3)
        tGt = tGt + Res(i, 3)
      ElseIf Len(dArr(i, 1)) > 0 Then
        Res(i, 3) = Gt
        Gt = 0
      End If
    Next i
    Res(1, 3) = tGt
    Sheets(SheetName(n)).Range("E6:G" & eRow) = Res
    Dic.RemoveAll
  Next n
End Sub
Nhấp chuột vào đây để mở rộng...
e đưa vào file của e nhưng sao không chạy được, e up lại a xem giúp, đây là file e xây dựng lại hoàn thiện, e cám ơn ah
 

File đính kèm

  • FORM Z_2019 (lan_1).xlsb
    92.2 KB · Đọc: 3
Upvote 0
queluatb đã viết:
e đưa vào file của e nhưng sao không chạy được, e up lại a xem giúp, đây là file e xây dựng lại hoàn thiện, e cám ơn ah
Nhấp chuột vào đây để mở rộng...
Cột Số lượng và Giá trị thay đổi
Chỉnh lại code
Mã: 
Option Explicit

Sub GPE()
  Dim sArr(), dArr(), Res(), SheetName(), Dic As Object, iKey
  Dim PX As String, fDay, eDay
  Dim n As Long, eRow As Long, sRow As Long, i As Long, ik As Long
  Dim Gt As Double, tGt As Double
 
  With Sheets("PSTP")
    eRow = .Range("A1000000").End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:M" & eRow).Value
  End With
  Set Dic = CreateObject("Scripting.Dictionary")
 
  SheetName = Array("Zep", "Zoxi", "Zstd")
  For n = 0 To UBound(SheetName)
    With Sheets(SheetName(n))
      PX = .Range("C1")
      fDay = .Range("D2"): eDay = .Range("E2")
      eRow = .Range("B1000000").End(xlUp).Row
    End With
    If eRow > 7 Then
      dArr = Sheets(SheetName(n)).Range("A6:C" & eRow).Value
      sRow = UBound(dArr)
      ReDim Res(1 To sRow, 1 To 3)
      For i = 1 To sRow
        iKey = dArr(i, 2)
        If Len(iKey) > 0 Then
          Dic.Item(iKey) = i
        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
              ik = Dic.Item(sArr(i, 6))
              If ik > 0 Then
                If Len(sArr(i, 10)) > 0 Then Res(ik, 1) = Res(ik, 1) + sArr(i, 10) '10 là thu tu cot So Luong
                If Len(sArr(i, 12)) > 0 Then Res(ik, 3) = Res(ik, 3) + sArr(i, 12) '12 là thu tu cot Gia tri
              End If
            End If
          End If
        End If
      Next i
    End If
    
    tGt = 0
    For i = sRow To 2 Step -1
      If Len(dArr(i, 2)) > 0 Then
        If Len(Res(i, 1)) > 0 And Len(Res(i, 3)) > 0 Then Res(i, 2) = Res(i, 3) / Res(i, 1)
        Gt = Gt + Res(i, 3)
        tGt = tGt + Res(i, 3)
      ElseIf Len(dArr(i, 1)) > 0 Then
        Res(i, 3) = Gt
        Gt = 0
      End If
    Next i
    Res(1, 3) = tGt
    Sheets(SheetName(n)).Range("E6:G" & eRow) = Res
    Dic.RemoveAll
  Next n
End Sub
 
Upvote 0
HieuCD đã viết:
Cột Số lượng và Giá trị thay đổi
Chỉnh lại code
Mã: 
Option Explicit

Sub GPE()
  Dim sArr(), dArr(), Res(), SheetName(), Dic As Object, iKey
  Dim PX As String, fDay, eDay
  Dim n As Long, eRow As Long, sRow As Long, i As Long, ik As Long
  Dim Gt As Double, tGt As Double

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

  SheetName = Array("Zep", "Zoxi", "Zstd")
  For n = 0 To UBound(SheetName)
    With Sheets(SheetName(n))
      PX = .Range("C1")
      fDay = .Range("D2"): eDay = .Range("E2")
      eRow = .Range("B1000000").End(xlUp).Row
    End With
    If eRow > 7 Then
      dArr = Sheets(SheetName(n)).Range("A6:C" & eRow).Value
      sRow = UBound(dArr)
      ReDim Res(1 To sRow, 1 To 3)
      For i = 1 To sRow
        iKey = dArr(i, 2)
        If Len(iKey) > 0 Then
          Dic.Item(iKey) = i
        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
              ik = Dic.Item(sArr(i, 6))
              If ik > 0 Then
                If Len(sArr(i, 10)) > 0 Then Res(ik, 1) = Res(ik, 1) + sArr(i, 10) '10 là thu tu cot So Luong
                If Len(sArr(i, 12)) > 0 Then Res(ik, 3) = Res(ik, 3) + sArr(i, 12) '12 là thu tu cot Gia tri
              End If
            End If
          End If
        End If
      Next i
    End If
  
    tGt = 0
    For i = sRow To 2 Step -1
      If Len(dArr(i, 2)) > 0 Then
        If Len(Res(i, 1)) > 0 And Len(Res(i, 3)) > 0 Then Res(i, 2) = Res(i, 3) / Res(i, 1)
        Gt = Gt + Res(i, 3)
        tGt = tGt + Res(i, 3)
      ElseIf Len(dArr(i, 1)) > 0 Then
        Res(i, 3) = Gt
        Gt = 0
      End If
    Next i
    Res(1, 3) = tGt
    Sheets(SheetName(n)).Range("E6:G" & eRow) = Res
    Dic.RemoveAll
  Next n
End Sub
Nhấp chuột vào đây để mở rộng...
e cám ơn sự hỗ trợ của ah, có lẽ hôm qua e gắn code của ah vào file lên công thức trong file a không nhìn được ạ, e gửi lại file gốc ah xem giúp vì e gán code vào một số dữ liệu chưa cho ra kết quả
 

File đính kèm

  • FORM Z_2019 (lan_Z).xlsb
    86.8 KB · Đọc: 4
Upvote 0
queluatb đã viết:
e cám ơn sự hỗ trợ của ah, có lẽ hôm qua e gắn code của ah vào file lên công thức trong file a không nhìn được ạ, e gửi lại file gốc ah xem giúp vì e gán code vào một số dữ liệu chưa cho ra kết quả
Nhấp chuột vào đây để mở rộng...
Cùng 1 chỉ tiêu công thức tính từng sheet khác nhau? tại sao? và có qui luật gì không?
Nếu cách tính quá khác biệt thì dùng công thức thủ công dể kiểm soát hơn
 
Upvote 0
HieuCD đã viết:
Cùng 1 chỉ tiêu công thức tính từng sheet khác nhau? tại sao? và có qui luật gì không?
Nếu cách tính quá khác biệt thì dùng công thức thủ công dể kiểm soát hơn
Nhấp chuột vào đây để mở rộng...
e cám ơn ah!
về cùng một chỉ tiêu nhưng công thức tính khác nhau do nó có hai hoạt động, hoạt động sản xuất của công ty và hoạt động khách hàng thuê gia công tại công ty, về cách tính giống nhau chỉ loại trừ chi phí nguyên vật liệu chính khỏi giá thành và để tránh phức tạp nhiều khi cũng coi hoạt động gia công hoàn thành 100%
Đồng thời chia ra các sheet khác nhau vì nó là sản phẩm độc lập của từng phân xưởng, như ở đây e có 3 phân xưởng sản xuất, có những chỉ tiêu dùng chung nhưng được tập hợp riêng cho từng phân xưởng
 
Lần chỉnh sửa cuối:
Upvote 0
queluatb đã viết:
e cám ơn ah!
về cùng một chỉ tiêu nhưng công thức tính khác nhau do nó có hai hoạt động, hoạt động sản xuất của công ty và hoạt động khách hàng thuê gia công tại công ty, về cách tính giống nhau chỉ loại trừ chi phí nguyên vật liệu chính khỏi giá thành và để tránh phức tạp nhiều khi cũng coi hoạt động gia công hoàn thành 100%
Đồng thời chia ra các sheet khác nhau vì nó là sản phẩm độc lập của từng phân xưởng, như ở đây e có 3 phân xưởng sản xuất, có những chỉ tiêu dùng chung nhưng được tập hợp riêng cho từng phân xưởng
Nhấp chuột vào đây để mở rộng...
Không nắm được chi tiết cụ thể cách tính và phân bổ chi phí cho từng SP và PX, nên phải mô phỏng lại công thức thủ công trong file
Chỉ chạy sub CreateTextFunction() 1 lần duy nhất để lấy công thức tính vào 3 cột phụ H, I, J. sau nầy cần thiết thì chỉnh tay trực tiếp trên 3 cột phụ nầy
Mã: 
Sub CreateTextFunction()
  Dim Msg, Style, Response
  Dim dArr(), Res(), SheetName(), n As Long, eRow As Long, i As Long, j As Long, tmp
 
Msg = "Xoa toan bo cong thuc va tao cong thuc moi" & Chr(10) & "Do you want to continue ?"     ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2
Response = MsgBox(Msg, Style)
If Response = vbYes Then    ' User chose Yes.
  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
        dArr = .Range("E6:G" & eRow).Formula
        ReDim Res(1 To UBound(dArr), 1 To 3)
        For i = 1 To UBound(dArr)
          For j = 1 To 3
            tmp = dArr(i, j)
            If Len(tmp) > 0 Then
              If InStr(1, tmp, "=SUMIFS") = 1 Then
                Res(i, j) = "Su"
              Else
                Res(i, j) = "'" & tmp
              End If
            End If
          Next j
        Next i
      End If
      .Range("H6:J" & eRow) = Res
    End With
  Next n
  MsgBox ("Da khoi tao lai cong thuc")
End If
End Sub
Khi cần tính giá thành thì chạy sub
Mã: 
Sub GPE()
  Dim sArr(), dArr(), Res1(), Res2(), tArr(), 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
 
  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))
      PX = .Range("C1")
      fDay = .Range("D2"): eDay = .Range("E2")
      eRow = .Range("B1000000").End(xlUp).Row
      If eRow > 7 Then
        dArr = Sheets(SheetName(n)).Range("A6:C" & eRow).Value
        sRow = UBound(dArr)
        tArr = Sheets(SheetName(n)).Range("H6:J" & eRow).Value
        ReDim Res(1 To sRow, 1 To 3)
        For i = 1 To sRow
          iKey = dArr(i, 2)
          If Len(iKey) > 0 Then
            If tArr(i, 1) = "Su" Then
              If Dic.exists("1#" & iKey) = False Then Dic.Add "1#" & iKey, i
            End If
            If tArr(i, 2) = "Su" Then
              If Dic.exists("2#" & iKey) = False Then Dic.Add "2#" & iKey, i
            End If
            If tArr(i, 3) = "Su" Then
              If Dic.exists("3#" & iKey) = False Then Dic.Add "3#" & iKey, i
            End If
          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
                ik = Dic.Item("1#" & sArr(i, 6))
                If ik > 0 Then Res(ik, 1) = Res(ik, 1) + sArr(i, 10)                   '10 là thu tu cot So Luong
                ik = Dic.Item("2#" & sArr(i, 6))
                If ik > 0 Then Res(ik, 2) = Res(ik, 2) + sArr(i, 11)
                ik = Dic.Item("3#" & sArr(i, 6))
                If ik > 0 Then Res(ik, 3) = Res(ik, 3) + sArr(i, 12)
              End If
            End If
          End If
        Next i
        Sheets(SheetName(n)).Activate
        For i = 1 To sRow
          For j = 1 To 3
            tmp = tArr(i, j)
            If Len(tmp) > 0 Then
              If tmp <> "Su" Then Res(i, j) = Application.Evaluate(tArr(i, j))
            End If
          Next j
        Next i
        .Range("K6:M" & eRow) = Res 'Ket qua tam
        '.Range("E6:G" & eRow) = Res 'Ket qua chinh thuc
        Dic.RemoveAll
      End If
    End With
  Next n
  Application.ScreenUpdating = True
End Sub
Trong code chỉ gán tạm kết quả vào 3 cột K:M, kiểm tra lại nếu chưa hợp lý thì chỉnh công thức và chạy code lại từ đầu, khi thật chính xác mới gán kết quả vào 3 cột E:G, lúc đó code tạo công thức ở cột phụ không được chạy lại
 

File đính kèm

  • FORM Z_2019 .xlsb
    93.6 KB · Đọc: 3
Upvote 0
queluatb đã viết:
e cám ơn ah!
về cùng một chỉ tiêu nhưng công thức tính khác nhau do nó có hai hoạt động, hoạt động sản xuất của công ty và hoạt động khách hàng thuê gia công tại công ty, về cách tính giống nhau chỉ loại trừ chi phí nguyên vật liệu chính khỏi giá thành và để tránh phức tạp nhiều khi cũng coi hoạt động gia công hoàn thành 100%
Đồng thời chia ra các sheet khác nhau vì nó là sản phẩm độc lập của từng phân xưởng, như ở đây e có 3 phân xưởng sản xuất, có những chỉ tiêu dùng chung nhưng được tập hợp riêng cho từng phân xưởng
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

  • FORM Z_2019 .xlsb
    86.5 KB · Đọc: 7
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

V
Tách chuỗi bất kỳ vào các cột khi gặp ký tự -
Trả lời
3
Đọc
92
DeTong
D
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
3 4 5
Trả lời
84
Đọc
2K
ptm0412
ptm0412
Salem999999999
Lọc dữ liệu có điều kiện
2
Trả lời
26
Đọc
670
VetMini
V
P
  • Question
Xin code gán mở theo tài khoản/profie đăng nhập bằng gmail sẵn trên trình duyệt
Trả lời
4
Đọc
209
phantu93
P
V
công thức của nó là gì ạ. mong mọi người giúp
Trả lời
1
Đọc
86
CHAOQUAY
C
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