Đếm xếp loại của đơn hàng (1 người xem)

[vanlinh_2904]

Chào anh/chị diễn đàn
Nhờ anh chị giúp em code VBA để đếm xếp loại của đơn hàng nếu đơn hàng có nhiều lần xếp loại trùng nhau thì chỉ tính 1 lần như file em đính kèm. Cảm ơn các anh chị

 

[Hoàng Tuấn 868]

Nhờ anh chị giúp em code VAB

Lấy đâu ra loại code "VAB" này bạn ơi.

 

[BuiQuangThuan]

Chào anh/chị diễn đàn
Nhờ anh chị giúp em code VBA để đếm xếp loại của đơn hàng nếu đơn hàng có nhiều lần xếp loại trùng nhau thì chỉ tính 1 lần như file em đính kèm. Cảm ơn các anh chị

Bạn thử tìm hiểu về dictionary xem. Sẽ giải quyết được vấn đề đó. Nếu không thể làm được thì tính tiếp

 

[vanlinh_2904]

Bạn thử tìm hiểu về dictionary xem. Sẽ giải quyết được vấn đề đó. Nếu không thể làm được thì tính tiếp

bạn có thể giúp mình với.

 

[Hoàng Tuấn 868]

bạn có thể giúp mình với.

Bạn nên tự tìm hiểu trước đi đã, vướng đâu thì đưa lên để gỡ chứ không làm gì cả mà cứ nhờ từ đầu đến cuối thì e rằng người muốn giúp cũng có phần nản.

 

[hoanganhvo2612]

Kết quả mình để ô F11 trở đi, bạn tuỳ biến lại code nhé.

Sub demBoTrung()
    Dim ar(), i As Integer, lr As Integer, dic1, dic2
    Dim kq(), k, idx
    lr = Range("A" & Rows.Count).End(3).Row
    ar = Range("A2:B" & lr).Value
    ReDim kq(1 To UBound(ar), 1 To 2)
    Set dic1 = CreateObject("Scripting.dictionary")
    Set dic2 = CreateObject("Scripting.dictionary")
    For i = 1 To UBound(ar)
        If Not dic1.exists(ar(i, 1)) Then
            k = k + 1
            dic1.Add ar(i, 1), k
            kq(k, 1) = ar(i, 1)
        End If
        If Not dic2.exists(ar(i, 1) & ar(i, 2)) Then
            dic2.Add ar(i, 1) & ar(i, 2), ""
            idx = dic1.Item(ar(i, 1))
            kq(idx, 2) = kq(idx, 2) + 1
        End If
    Next
    If k Then
        Range("F11").Resize(k, 2) = kq
    End If
End Sub

 

[vanlinh_2904]

Kết quả mình để ô F11 trở đi, bạn tuỳ biến lại code nhé.

Sub demBoTrung()
    Dim ar(), i As Integer, lr As Integer, dic1, dic2
    Dim kq(), k, idx
    lr = Range("A" & Rows.Count).End(3).Row
    ar = Range("A2:B" & lr).Value
    ReDim kq(1 To UBound(ar), 1 To 2)
    Set dic1 = CreateObject("Scripting.dictionary")
    Set dic2 = CreateObject("Scripting.dictionary")
    For i = 1 To UBound(ar)
        If Not dic1.exists(ar(i, 1)) Then
            k = k + 1
            dic1.Add ar(i, 1), k
            kq(k, 1) = ar(i, 1)
        End If
        If Not dic2.exists(ar(i, 1) & ar(i, 2)) Then
            dic2.Add ar(i, 1) & ar(i, 2), ""
            idx = dic1.Item(ar(i, 1))
            kq(idx, 2) = kq(idx, 2) + 1
        End If
    Next
    If k Then
        Range("F11").Resize(k, 2) = kq
    End If
End Sub

Nhờ bạn sửa lại giúp mình kết quả ở cột C tương ứng với từng dòng của đơn hàng ở cột A. cảm ơn bạn nhiều.