Tổng hợp số lượng theo từng ký hiệu mã sản phẩm..!

C

CRV

SMod
Thành viên BQT
Đây là code mình đã chỉnh đến lần 4 do yêu cầu bạn đưa từ ban đầu không rõ ràng & đầy đủ.
Nếu còn vấn đề gì nữa cho chủ đề và vấn đề này của bạn thì bạn tự mình tìm hiểu rồi tự giải quyết nhé.
Bởi có thể các yêu cầu tiếp khác sẽ thay đổi lại toàn bộ cách làm như đập đi làm lại vậy.

Qua đây mình cũng cảm ơn bạn rất nhiều vì đã đóng góp ủng hộ diễn đàn.
Mình rất khuyến khích học và hỏi nhiều ,nhưng không phải cứ đóng góp là có thể cùng một vấn đề ban đầu mà có thể viết bài khó hiểu và nhỏ giọt lắt nhắt... dẫn đến mãi chưa có sự kết thúc. Do đó bạn cần phải đưa trường hợp tổng quát nhất.
Nếu bạn có vấn đề gì khác thì có thể hỏi, nếu trong điều kiện khả năng thì mình sẽ cố giúp.

Dưới đây là code chỉnh lại lần 4:
Mã: 
Option Explicit
Const CRV__ As String = "https://tuhocvba.net/"
Public Sub THVBA_CRV___4()
    '//Khai bao tham so
    Dim Dic As Object, sheet As Worksheet, cell As Range
    Dim data As Variant, result As Variant, ma As Variant, Key As Variant
    Dim i As Long, j As Long, k As Long, n As Long, r As Long
    Dim c As Integer, colMa As Integer, Tmr As Double
    Tmr = Timer()

    '// Xac dinh mang du lieu dau vao & kich thuoc mang ket qua dau ra
    Set sheet = ThisWorkbook.Worksheets("DL_N")
    If sheet.AutoFilterMode Then sheet.AutoFilterMode = False
    data = sheet.Range("C3").CurrentRegion.Value
   
    Set sheet = ThisWorkbook.Worksheets("T_H")
    If sheet.AutoFilterMode Then sheet.AutoFilterMode = False
    r = sheet.Cells(sheet.Rows.Count, 2).End(xlUp).Row
    c = sheet.Cells(3, sheet.Columns.Count).End(xlToLeft).Column
    If (r < 4) Or (c < 3) Then Exit Sub
   
    '// Khoi tao Dictionary
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    result = sheet.Range("A3:A" & r).Resize(, c).Value
    For j = 3 To c Step 3
        Key = result(1, j)
        If Not Dic.Exists(Key) And Len(Key) > 0 Then
            Dic.Add Key, j: sheet.Cells(4, j).Resize(10000).ClearContents
        End If
    Next j
    For i = 2 To UBound(result, 1)
        Key = result(i, 2)
        If Not Dic.Exists(Key) And Len(Key) > 0 Then Dic.Add Key, i
    Next i
   
    n = UBound(data, 2): colMa = 9
    '// Xu ly tong hop du lieu theo ma & phan loai ma
    For i = 2 To UBound(data, 1)
        For j = 1 To colMa
            If Len(data(i, j)) > 0 Then
                Key = data(i, j)
                If Dic.Exists(Key) Then
                    r = Dic.Item(Key)
                    For c = colMa + 1 To n
                        Key = data(1, c)
                        If Dic.Exists(Key) Then
                            result(r, Dic.Item(Key)) = _
                            result(r, Dic.Item(Key)) + data(i, c)
                        End If
                    Next c
                End If
            End If
        Next j
    Next i
    r = UBound(result, 1): c = UBound(result, 2)
    sheet.Range("A3").Resize(r, c).Value = result
    '//Thong bao ket thuc
    Tmr = WorksheetFunction.Round(Timer() - Tmr, 2)
    MsgBox "Done and success, " & vbNewLine & "processing time is: " & Tmr & " seconds.", _
        vbInformation + vbOKOnly, CRV__
End Sub
 
S

shnhatha

Yêu THVBA
CRV nói:
Đây là code mình đã chỉnh đến lần 4 do yêu cầu bạn đưa từ ban đầu không rõ ràng & đầy đủ.
Nếu còn vấn đề gì nữa cho chủ đề và vấn đề này của bạn thì bạn tự mình tìm hiểu rồi tự giải quyết nhé.
Bởi có thể các yêu cầu tiếp khác sẽ thay đổi lại toàn bộ cách làm như đập đi làm lại vậy.

Qua đây mình cũng cảm ơn bạn rất nhiều vì đã đóng góp ủng hộ diễn đàn.
Nhưng không phải cứ đóng góp là có thể viết bài khó hiểu và nhỏ giọt lắt nhắt.
Nếu bạn có vấn đề gì khác thì có thể hỏi, nếu trong điều kiện khả năng thì mình sẽ cố giúp.

Dưới đây là code chỉnh lại lần 4:
Mã: 
Option Explicit
Const CRV__ As String = "https://tuhocvba.net/"
Public Sub THVBA_CRV___4()
    '//Khai bao tham so
    Dim Dic As Object, sheet As Worksheet, cell As Range
    Dim data As Variant, result As Variant, ma As Variant, Key As Variant
    Dim i As Long, j As Long, k As Long, n As Long, r As Long
    Dim c As Integer, colMa As Integer, Tmr As Double
    Tmr = Timer()

    '// Xac dinh mang du lieu dau vao & kich thuoc mang ket qua dau ra
    Set sheet = ThisWorkbook.Worksheets("DL_N")
    If sheet.AutoFilterMode Then sheet.AutoFilterMode = False
    data = sheet.Range("C3").CurrentRegion.Value
   
    Set sheet = ThisWorkbook.Worksheets("T_H")
    If sheet.AutoFilterMode Then sheet.AutoFilterMode = False
    r = sheet.Cells(sheet.Rows.Count, 2).End(xlUp).Row
    c = sheet.Cells(3, sheet.Columns.Count).End(xlToLeft).Column
    If (r < 4) Or (c < 3) Then Exit Sub
   
    '// Khoi tao Dictionary
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    result = sheet.Range("A3:A" & r).Resize(, c).Value
    For j = 3 To c Step 3
        Key = result(1, j)
        If Not Dic.Exists(Key) And Len(Key) > 0 Then
            Dic.Add Key, j: sheet.Cells(4, j).Resize(10000).ClearContents
        End If
    Next j
    For i = 2 To UBound(result, 1)
        Key = result(i, 2)
        If Not Dic.Exists(Key) And Len(Key) > 0 Then Dic.Add Key, i
    Next i
   
    n = UBound(data, 2): colMa = 9
    '// Xu ly tong hop du lieu theo ma & phan loai ma
    For i = 2 To UBound(data, 1)
        For j = 1 To colMa
            If Len(data(i, j)) > 0 Then
                Key = data(i, j)
                If Dic.Exists(Key) Then
                    r = Dic.Item(Key)
                    For c = colMa + 1 To n
                        Key = data(1, c)
                        If Dic.Exists(Key) Then
                            result(r, Dic.Item(Key)) = _
                            result(r, Dic.Item(Key)) + data(i, c)
                        End If
                    Next c
                End If
            End If
        Next j
    Next i
    r = UBound(result, 1): c = UBound(result, 2)
    sheet.Range("A3").Resize(r, c).Value = result
    '//Thong bao ket thuc
    Tmr = WorksheetFunction.Round(Timer() - Tmr, 2)
    MsgBox "Done and success, " & vbNewLine & "processing time is: " & Tmr & " seconds.", _
        vbInformation + vbOKOnly, CRV__
End Sub
Nhấn để mở rộng...
Thực sự kg phải như bạn nghĩ bởi sự trả công gì đó ...Lý do mình kg chuyên nghiệp chỉ học mót từng chút một nên có nhiều thắc mắc chưa thể tự giải quyết ..Mình cũng hiểu chỉ cần sự tận tình trong việc trả lời của bạn đã hơn nhiều những gì mình bỏ ra..Mong thông cảm .!
 
B

Binana

VIP

shnhatha nói:
Thực sự kg phải như bạn nghĩ bởi sự trả công gì đó ...Lý do mình kg chuyên nghiệp chỉ học mót từng chút một nên có nhiều thắc mắc chưa thể tự giải quyết ..Mình cũng hiểu chỉ cần sự tận tình trong việc trả lời của bạn đã hơn nhiều những gì mình bỏ ra..Mong thông cảm .!
Nhấn để mở rộng...
Mình đồng quan điểm với smod ở trên . Còn nếu bạn muốn tham khảo code của mình có thể sửa code như sau
Sau khi chạy code của smod trên nữa. sao thấy ra kết quả khác nhau là sao ta
Mã: 
Option Explicit

Sub ABC()
    Dim Dic As Object, Arr(), sArr(), Res(), i&, Key$, j&, Tmp$
    Dim S, r&, sR&, iC&, Tmr As Double
    Tmr = Timer()
    Application.ScreenUpdating = 0
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("DL_N")
        Arr = .Range("C3").CurrentRegion.Value
        For j = 1 To UBound(Arr, 2)
            If j < 10 Then
                For i = 2 To UBound(Arr)
                    If Arr(i, j) <> Empty Then
                        Key = Arr(i, j)
                        Dic(Key) = Dic(Key) & "," & i
                    End If
                Next
            Else
                Dic.Add Arr(1, j), j
            End If
        Next
    End With
    With Sheets("T_H")
        iC = .Cells(3, Columns.Count).End(1).Column - 2
        sArr = .Range("A3").Resize(.Range("B" & Rows.Count).End(3).Row - 2, iC + 2).Value
        For j = 3 To iC Step 3
            ReDim Res(1 To UBound(sArr) - 1, 1 To 1)
            If Dic.Exists(sArr(1, j)) = True Then
                For i = 2 To UBound(sArr)
                    Key = sArr(i, 2)
                    If Dic.Exists(Key) = True Then
                        S = Split(Dic.Item(Key), ",")
                        For r = 1 To UBound(S)
                            Res(i - 1, 1) = Res(i - 1, 1) + Arr(S(r), Dic(sArr(1, j)))
                        Next
                    End If
                Next
                .Cells(4, j).Resize(UBound(sArr) - 1).Value = Res
            Else
                .Cells(4, j).Resize(UBound(sArr) - 1).ClearContents
            End If
        Next
    End With
    Application.ScreenUpdating = 1
    MsgBox "Hoàn thành: " & Timer() - Tmr
End Sub
 
S

shnhatha

Yêu THVBA
Binana nói:
Mình đồng quan điểm với smod ở trên . Còn nếu bạn muốn tham khảo code của mình có thể sửa code như sau
Sau khi chạy code của smod trên nữa. sao thấy ra kết quả khác nhau là sao ta
Mã: 
Option Explicit

Sub ABC()
    Dim Dic As Object, Arr(), sArr(), Res(), i&, Key$, j&, Tmp$
    Dim S, r&, sR&, iC&, Tmr As Double
    Tmr = Timer()
    Application.ScreenUpdating = 0
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("DL_N")
        Arr = .Range("C3").CurrentRegion.Value
        For j = 1 To UBound(Arr, 2)
            If j < 10 Then
                For i = 2 To UBound(Arr)
                    If Arr(i, j) <> Empty Then
                        Key = Arr(i, j)
                        Dic(Key) = Dic(Key) & "," & i
                    End If
                Next
            Else
                Dic.Add Arr(1, j), j
            End If
        Next
    End With
    With Sheets("T_H")
        iC = .Cells(3, Columns.Count).End(1).Column - 2
        sArr = .Range("A3").Resize(.Range("B" & Rows.Count).End(3).Row - 2, iC + 2).Value
        For j = 3 To iC Step 3
            ReDim Res(1 To UBound(sArr) - 1, 1 To 1)
            If Dic.Exists(sArr(1, j)) = True Then
                For i = 2 To UBound(sArr)
                    Key = sArr(i, 2)
                    If Dic.Exists(Key) = True Then
                        S = Split(Dic.Item(Key), ",")
                        For r = 1 To UBound(S)
                            Res(i - 1, 1) = Res(i - 1, 1) + Arr(S(r), Dic(sArr(1, j)))
                        Next
                    End If
                Next
                .Cells(4, j).Resize(UBound(sArr) - 1).Value = Res
            Else
                .Cells(4, j).Resize(UBound(sArr) - 1).ClearContents
            End If
        Next
    End With
    Application.ScreenUpdating = 1
    MsgBox "Hoàn thành: " & Timer() - Tmr
End Sub
Nhấn để mở rộng...
Xin cảm ơn ..!Những nội dung chủ đề sau mình sẽ rút kinh nghiệm rõ ràng hơn..
Về vấn đề bạn @CRV nhắc nhở mình ghi nhận, quả thực mình không có ý muốn dai dẳng nhờ thay đổi code thế này thế khác..chỉ là trong quá trình chạy thử khi mình xóa bỏ mã sản phẩm tại cột B thì code vẫn cho ra kết qua tại dòng đó với code của bạn khi mình sửa đổi cũng thế..! (Hiện giờ code của 2 bạn đã rất tốt).
Một lần nữa thành thật cảm ơn và mong hai bạn thông cảm ..!
 
  • Love
Reactions: CRV
Bạn phải đăng nhập hoặc đăng ký để bình luận.
Top