Nhờ trợ giúp tổng hợp số lượng lỗi theo mã sản phẩm từng tháng

Liên hệ QC
K

kaka01

Thành viên chính thức
Tham gia
12/2/16
Bài viết
55
Được thích
11
Xin chào các anh/chị diễn đàn GPE!
Em có dữ liệu cần tổng hợp số lượng lỗi theo loại của từng mã sản phẩm theo tháng như file đính kèm nhờ các anh/chị trợ giúp!
- Từ sheet "DMloi" và Sheet "SLSP" tổng hợp ra 3 sheet "TH-A", "TH-B" và "TH_ALL" , ALL = (A+B)
- Các cột cẩn tổng hợp tại sheet "DMloi" là (3,5,8 và 10)
- Ở các sheet TH này mục đích thống kê theo từng tháng số lượng lỗi của mỗi sản phẩm theo các tiêu chí A, B và ALL, và tổng sản phẩm của mỗi tháng (tổng sản phẩm này là của tất cả các mã có trong sheet "SLSP" theo mỗi tháng)
(Phần chữ bôi đỏ ở các sheet TH là dữ liệu mong muốn tổng hợp.

Em xin chân thành cảm ơn!
 

File đính kèm

  • Tong hop ty le_004052020.xlsb
    45.2 KB · Đọc: 23
Sắp xếp theo thời gian sắp xếp theo bầu chọn
kaka01 đã viết:
Xin chào các anh/chị diễn đàn GPE!
Em có dữ liệu cần tổng hợp số lượng lỗi theo loại của từng mã sản phẩm theo tháng như file đính kèm nhờ các anh/chị trợ giúp!
- Từ sheet "DMloi" và Sheet "SLSP" tổng hợp ra 3 sheet "TH-A", "TH-B" và "TH_ALL" , ALL = (A+B)
- Các cột cẩn tổng hợp tại sheet "DMloi" là (3,5,8 và 10)
- Ở các sheet TH này mục đích thống kê theo từng tháng số lượng lỗi của mỗi sản phẩm theo các tiêu chí A, B và ALL, và tổng sản phẩm của mỗi tháng (tổng sản phẩm này là của tất cả các mã có trong sheet "SLSP" theo mỗi tháng)
(Phần chữ bôi đỏ ở các sheet TH là dữ liệu mong muốn tổng hợp.

Em xin chân thành cảm ơn!
Nhấp chuột vào đây để mở rộng...
Chạy Sub ABC
Mã: 
Sub ABC()
  Dim aLoi(), aSL(), Arr(), Res(), aSh, Dic As Object
  Dim i&, iR&, j&, jC&, sRow&, sRowRes&, iKey$
  Const spA$ = "A"
  Const spB$ = "B"
 
  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("SLSP")
    aSL = .Range("A14:O14").Value
  End With
  With Sheets("DMLoi")
    aLoi = .Range("C5", .Range("J" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(aLoi)
  ReDim Arr(1 To sRow + 5, 1 To 14)
  sRowRes = UBound(Arr)
  ReDim Res(1 To 3)
  For i = 1 To 3
    Res(i) = Arr
  Next i
  For i = 1 To sRow
    jC = aLoi(i, 6) + 2
    If aLoi(i, 8) = spA Then
      iKey = aLoi(i, 1)
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 3, aLoi(i, 1), aLoi(i, 3))
      iKey = iKey & "#" & spA
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 1, aLoi(i, 1), aLoi(i, 3))
    ElseIf aLoi(i, 8) = spB Then
      iKey = aLoi(i, 1)
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 3, aLoi(i, 1), aLoi(i, 3))
      iKey = iKey & "#" & spB
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 2, aLoi(i, 1), aLoi(i, 3))
    End If
  Next i
  aSh = Array("", "TH-A", "TH-B", "TH-ALL")
  For i = 1 To 3
    Arr = Res(i)
    sRow = Arr(sRowRes, 1)
    Arr(sRow + 1, 2) = "Ty le":         Arr(sRow + 2, 2) = "Ty le luy tien"
    Arr(sRow + 3, 2) = "Tong so loi":   Arr(sRow + 4, 2) = "Tong san pham"
    For j = 3 To 14
      For iR = 1 To sRow
        Arr(sRow + 3, j) = Arr(sRow + 3, j) + Arr(iR, j)
      Next iR
      Arr(sRow + 4, j) = aSL(1, j)
      If Arr(sRow + 4, j) > 0 Then Arr(sRow + 1, j) = Arr(sRow + 3, j) / Arr(sRow + 4, j) * 1000000
    Next j
    With Sheets(aSh(i))
      iR = .Range("B" & Rows.Count).End(xlUp).Row
      If iR > 4 Then .Range("A5:N" & iR).ClearContents
      Sheets(aSh(i)).Range("A5").Resize(sRow + 4, 14) = Arr
    End With
  Next i
End Sub

Private Sub AddRes(Dic, Res, jC, sRowRes, iKey, ByVal j&, ByVal MaSp$, ByVal Sl#)
  Dim iR&
  If Dic.exists(iKey) = False Then
    iR = Res(j)(sRowRes, 1) + 1
    Res(j)(sRowRes, 1) = iR
    Dic.Add iKey, iR
    Res(j)(iR, 1) = iR
    Res(j)(iR, 2) = MaSp
  End If
  iR = Dic.Item(iKey)
  Res(j)(iR, jC) = Res(j)(iR, jC) + Sl
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy Sub ABC
Mã: 
Sub ABC()
  Dim aLoi(), aSL(), Arr(), Res(), aSh, Dic As Object
  Dim i&, iR&, j&, jC&, sRow&, sRowRes&, iKey$
  Const spA$ = "A"
  Const spB$ = "B"

  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("SLSP")
    aSL = .Range("A14:O14").Value
  End With
  With Sheets("DMLoi")
    aLoi = .Range("C5", .Range("J" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(aLoi)
  ReDim Arr(1 To sRow + 5, 1 To 14)
  sRowRes = UBound(Arr)
  ReDim Res(1 To 3)
  For i = 1 To 3
    Res(i) = Arr
  Next i
  For i = 1 To sRow
    jC = aLoi(i, 6) + 2
    If aLoi(i, 8) = spA Then
      iKey = aLoi(i, 1)
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 3, aLoi(i, 1), aLoi(i, 3))
      iKey = iKey & "#" & spA
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 1, aLoi(i, 1), aLoi(i, 3))
    ElseIf aLoi(i, 8) = spB Then
      iKey = aLoi(i, 1)
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 3, aLoi(i, 1), aLoi(i, 3))
      iKey = iKey & "#" & spB
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 2, aLoi(i, 1), aLoi(i, 3))
    End If
  Next i
  aSh = Array("", "TH-A", "TH-B", "TH-ALL")
  For i = 1 To 3
    Arr = Res(i)
    sRow = Arr(sRowRes, 1)
    Arr(sRow + 1, 2) = "Ty le":         Arr(sRow + 2, 2) = "Ty le luy tien"
    Arr(sRow + 3, 2) = "Tong so loi":   Arr(sRow + 4, 2) = "Tong san pham"
    For j = 3 To 14
      For iR = 1 To sRow
        Arr(sRow + 3, j) = Arr(sRow + 3, j) + Arr(iR, j)
      Next iR
      Arr(sRow + 4, j) = aSL(1, j)
      If Arr(sRow + 4, j) > 0 Then Arr(sRow + 1, j) = Arr(sRow + 3, j) / Arr(sRow + 4, j) * 1000000
    Next j
    With Sheets(aSh(i))
      iR = .Range("B" & Rows.Count).End(xlUp).Row
      If iR > 4 Then .Range("A5:N" & iR).ClearContents
      Sheets(aSh(i)).Range("A5").Resize(sRow + 4, 14) = Arr
    End With
  Next i
End Sub

Private Sub AddRes(Dic, Res, jC, sRowRes, iKey, ByVal j&, ByVal MaSp$, ByVal Sl#)
  Dim iR&
  If Dic.exists(iKey) = False Then
    iR = Res(j)(sRowRes, 1) + 1
    Res(j)(sRowRes, 1) = iR
    Dic.Add iKey, iR
    Res(j)(iR, 1) = iR
    Res(j)(iR, 2) = MaSp
  End If
  iR = Dic.Item(iKey)
  Res(j)(iR, jC) = Res(j)(iR, jC) + Sl
End Sub
Nhấp chuột vào đây để mở rộng...
Eo ôi, con nhìn vào mà thấy hãi quá Bác ơi.
Bác cho con các biến dưới đây:
..Sub AddRes(Dic, Res, jC, sRowRes, iKey,..
khi qua một sub khác không cần phải khai báo lại cũng được phải không ạ, nó vẫn hiểu là dữ liệu truyền vào kiểu của sub trước?
 
Lần chỉnh sửa cuối:
Upvote 0
Xin các anh chị cho em code trừ lùi nhập trước- xuất trước với ah.
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Eo ôi, con nhìn vào mà thấy hãi quá Bác ơi.
Bác cho con các biến dưới đây:
..Sub AddRes(Dic, Res, jC, sRowRes, iKey,..
khi qua một sub khác không cần phải khai báo lại cũng được phải không ạ, nó vẫn hiểu là dữ liệu truyền vào kiểu của sub trước?
Nhấp chuột vào đây để mở rộng...
Sub AddRes(Dic, Res, ...
Viết đầy đủ là
Sub AddRes(byref Dic, byref Res, ...
2 sub dùng chung biến, kết quả của biến sẽ truyền qua lại 2 sub
 
Upvote 0
Eo ôi, con nhìn vào mà thấy hãi quá Bác ơi. . . . . .
Nhấp chuột vào đây để mở rộng...
Cái này dễ hiểu ngay này:
PHP: 
Sub TongHopLoi()
Dim Rws As Long, J As Long, W As Integer, Col As Integer

Sheets("DMLoi").Select
Rws = [c9].CurrentRegion.Rows.Count
ReDim Arr(1 To Rws, 1 To 8)
Arr() = [c5:j13].Value
ReDim ArrA(1 To 4, 1 To 13):                ReDim ArrB(1 To 4, 1 To 13)
ReDim ArrC(1 To 4, 1 To 13)
For W = 1 To 4     'Duyêt Theo Danh Muc Duy Nhât Cua Mã SF    '
    ArrA(W, 1) = Cells(W + 4, "o").Value:       ArrB(W, 1) = ArrA(W, 1)
    ArrC(W, 1) = ArrB(W, 1)
    For J = 1 To UBound(Arr())   
        If Arr(J, 1) = Cells(W + 4, "O").Value Then
            If Arr(J, 8) = "A" Then
                ArrA(W, 1 + Arr(J, 6)) = ArrA(W, 1 + Arr(J, 6)) + Arr(J, 3)
            ElseIf Arr(J, 8) = "B" Then
                ArrB(W, 1 + Arr(J, 6)) = ArrB(W, 1 + Arr(J, 6)) + Arr(J, 3)
            End If
            ArrC(W, 1 + Arr(J, 6)) = ArrC(W, 1 + Arr(J, 6)) + Arr(J, 3)
        End If
    Next J
Next W
Sheets("TH-A").[B5].Resize(4, 12).Value = ArrA()
Sheets("TH-B").[B5].Resize(4, 12).Value = ArrB()
Sheets("TH-ALL").[B5].Resize(4, 12).Value = ArrC()
MsgBox "Xong Cau 1"
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy Sub ABC
Mã: 
Sub ABC()
  Dim aLoi(), aSL(), Arr(), Res(), aSh, Dic As Object
  Dim i&, iR&, j&, jC&, sRow&, sRowRes&, iKey$
  Const spA$ = "A"
  Const spB$ = "B"

  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("SLSP")
    aSL = .Range("A14:O14").Value
  End With
  With Sheets("DMLoi")
    aLoi = .Range("C5", .Range("J" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(aLoi)
  ReDim Arr(1 To sRow + 5, 1 To 14)
  sRowRes = UBound(Arr)
  ReDim Res(1 To 3)
  For i = 1 To 3
    Res(i) = Arr
  Next i
  For i = 1 To sRow
    jC = aLoi(i, 6) + 2
    If aLoi(i, 8) = spA Then
      iKey = aLoi(i, 1)
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 3, aLoi(i, 1), aLoi(i, 3))
      iKey = iKey & "#" & spA
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 1, aLoi(i, 1), aLoi(i, 3))
    ElseIf aLoi(i, 8) = spB Then
      iKey = aLoi(i, 1)
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 3, aLoi(i, 1), aLoi(i, 3))
      iKey = iKey & "#" & spB
      Call AddRes(Dic, Res, jC, sRowRes, iKey, 2, aLoi(i, 1), aLoi(i, 3))
    End If
  Next i
  aSh = Array("", "TH-A", "TH-B", "TH-ALL")
  For i = 1 To 3
    Arr = Res(i)
    sRow = Arr(sRowRes, 1)
    Arr(sRow + 1, 2) = "Ty le":         Arr(sRow + 2, 2) = "Ty le luy tien"
    Arr(sRow + 3, 2) = "Tong so loi":   Arr(sRow + 4, 2) = "Tong san pham"
    For j = 3 To 14
      For iR = 1 To sRow
        Arr(sRow + 3, j) = Arr(sRow + 3, j) + Arr(iR, j)
      Next iR
      Arr(sRow + 4, j) = aSL(1, j)
      If Arr(sRow + 4, j) > 0 Then Arr(sRow + 1, j) = Arr(sRow + 3, j) / Arr(sRow + 4, j) * 1000000
    Next j
    With Sheets(aSh(i))
      iR = .Range("B" & Rows.Count).End(xlUp).Row
      If iR > 4 Then .Range("A5:N" & iR).ClearContents
      Sheets(aSh(i)).Range("A5").Resize(sRow + 4, 14) = Arr
    End With
  Next i
End Sub

Private Sub AddRes(Dic, Res, jC, sRowRes, iKey, ByVal j&, ByVal MaSp$, ByVal Sl#)
  Dim iR&
  If Dic.exists(iKey) = False Then
    iR = Res(j)(sRowRes, 1) + 1
    Res(j)(sRowRes, 1) = iR
    Dic.Add iKey, iR
    Res(j)(iR, 1) = iR
    Res(j)(iR, 2) = MaSp
  End If
  iR = Dic.Item(iKey)
  Res(j)(iR, jC) = Res(j)(iR, jC) + Sl
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh HieuCD rất nhiều!
Code đã đáp ứng được với bài của em
em nghiên cứu thêm để vận dụng tiếp có gì chưa hiểu rõ nhờ anh hỗ trợ tiếp
Trân trọng cảm ơn anh!
 
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

N
Nhờ các bác hỗ trợ lọc, thống kê dữ liệu giúp
Trả lời
0
Đọc
4
ntphucit
N
B
49 + 49+ 1= 100? Vã mồ hôi luôn
Trả lời
12
Đọc
1K
-_-
-_-
H
Sửa code tính lũy kế ạ
Trả lời
3
Đọc
39
Hoàng Tuấn 868
H
Quyen182
  • Question
Nhờ chỉnh code VBA để tô màu dòng chứa Activecell và không làm mất màu gốc
Trả lời
3
Đọc
94
HeSanbi
HeSanbi
H
Nhờ hướng dẫn tạo bảng như hình vẽ
Trả lời
0
Đọc
32
hoaiantrinh
H
L
Đổi màu chữ trong VBA
Trả lời
11
Đọc
103
lvh1064
L
V
Chỉ cách sửa lỗi trong Excell
Trả lời
1
Đọc
36
A-T
A
T
Không đếm dữ liệu rỗng trong PivotTable
Trả lời
9
Đọc
1K
Dũng NĐ
Dũng NĐ
H
Hỗ trợ lấy danh sách dữ liệu thỏa mãn điều kiện
Trả lời
3
Đọc
142
DeTong
D
PhanTuHuong
Bàn về môn thể thao bóng bàn nào!
    • Thích
    • Yêu thích
    • Cười
2
Trả lời
38
Đọc
2K
lvh1064
L
salam
Ẩn ảnh sau chữ trong excel
Trả lời
11
Đọc
29K
itusbbk
itusbbk
nobita994
Trừ số lượng dần theo dòng khi quét Sumif tổng có tên sản phẩm bị trùng.
Trả lời
4
Đọc
126
nobita994
nobita994
F
  • Question
Nhờ tư vấn cách tạo QR trong Excel
Trả lời
7
Đọc
552
huuthang_bd
huuthang_bd
nguyen trung cuong
File chứa marco không mở được.
Trả lời
3
Đọc
109
hvnhpro
H
Tienvinh191
  • Question
Nhờ viết Code lấy dữ liệu tờ khai hải quan vào bảng tổng hợp
2
Trả lời
25
Đọc
2K
haott
H
CodyPham97
tạo biểu tượng thay thế nhấn đúp chuột
Trả lời
4
Đọc
94
phansythao
phansythao
dovanha1994
Giúp e tìm nguyên nhân sai và hướng dẫn e đọc file này với ạ
    • Phẫn nộ
Trả lời
4
Đọc
137
SA_DQ
SA_DQ
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
10
Đọc
608
20050911
20050911
N
Giúp sửa mã code
2
Trả lời
20
Đọc
474
Nguyễn Diêu Hiền
N
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11/2024
    • Thích
    • Yêu thích
Trả lời
1
Đọc
101
SA_DQ
SA_DQ
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

Back
Top Bottom