Tính tổng theo điều kiện (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
queluatb

queluatb

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

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

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

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

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

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

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

K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table (1 người xem)
Trả lời
7
Đọc
252
ptm0412
ptm0412
D
Nhờ các bác giúp đỡ vấn đề tìm kiếm dữ liệu (4 người xem)
Trả lời
6
Đọc
136
Hoàng Tuấn 868
H
P
Hỏi về cách dò tìm từ dưới lên trên, dò tìm trong 2 bảng (1 người xem)
Trả lời
7
Đọc
177
kenytien
K
P
Xin tư vấn về cách tạo bảng quản lý vải
    • Cười
Trả lời
14
Đọc
233
VetMini
V
D
Nhờ giúp đỡ về công thức xếp loại rèn luyện theo thông tư 22/2021/TT-BGDĐT (1 người xem)
Trả lời
8
Đọc
118
thanthanhan
T
Maika8008
Tặng file quản lý vật tư - công nợ (nhập xuất kho hàng và công nợ khách hàng)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
116
Đọc
25K
Thanh Tam 07
T
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ (1 người xem)
2
Trả lời
25
Đọc
890
befaint
befaint
A
NHỜ ANH CHỊ GIÚP EM CÂU LỆNH NÀY VỚI Ạ
Trả lời
1
Đọc
117
ongke0711
ongke0711
H
Chuyển file *xml hóa đơn điện tử sang excel
    • Thích
Trả lời
4
Đọc
210
htrunga2
H
K
Lọc một mã sản phẩm có nhiều đơn giá thành một file riêng
Trả lời
2
Đọc
114
ketoansb123
K
D
Nhờ trợ giúp xác định thứ tự của các từ và cụm từ trong 1 chuỗi văn bản.
Trả lời
10
Đọc
270
Phuocam
Phuocam
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ
Trả lời
19
Đọc
573
thuytrangbp28
T
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
6
Đọc
197
Trungvt3
Trungvt3
H
  • Question Question
Tô đậm tiêu đề cho cho các sheet
Trả lời
4
Đọc
192
hieu998
H
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
    • Thích
Trả lời
1
Đọc
981
GPE-Trợ Lý
GPE-Trợ Lý
Z
TRỢ GIÚP K SORT ĐƯỢC THỨ TỰ NGÀY THÁNG NĂM TRONG EXCEL
Trả lời
2
Đọc
128
Duy Tùng 9x
Duy Tùng 9x
H
Tách file nguồn thành nhiều file dựa vào điều kiện (1 người xem)
Trả lời
5
Đọc
185
LePhatHuy
LePhatHuy
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
7
Đọc
372
fujishima
F
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
49
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
tính thể tích bồn dầu hình trụ elip nằm ngang
Trả lời
10
Đọc
47K
pvkiem
P
Xem thêm…

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

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom