Tính số lần xuất hiện của trá trị (1 người xem)

[hungdiep85]

Chào các Thầy/Cô và Anh/Chị


Mong các Thầy/Cô và Anh/Chị giúp em đoạn code với.

Sheet1 D3:V3 tính số lần xuất hiện của giá trị qua sheet 2 ạ
(Ví dụ như là em muốn tính vùng nào thì em chọn vùng đó rồi chạy code ạ)

Em cảm ơn trước ạ

 

[mhung12005]

Chào các Thầy/Cô và Anh/Chị


Mong các Thầy/Cô và Anh/Chị giúp em đoạn code với.

Sheet1 D3:V3 tính số lần xuất hiện của giá trị qua sheet 2 ạ
(Ý là em muốn tính vùng nào thì em chọn vùng đó rồi chạy code ạ)

Em cảm ơn trước ạ

Công thức có được không bạn :

C2 =SUMPRODUCT((Sheet1!$D$3:$V$3=Sheet2!B2)*1)

 

[hungdiep85]

Công thức có được không bạn :

Dạ hàm hay code cũng được Anh , nhưng A2 đến A20 đó là em ví dụ thôi à, nó là tên người và nằm ở nhiều chổ khác nhau hết và dữ liệu đến 1 tháng lận nhiếu lắm, nên em muốn là vừa lấy được tên người ra và vừa tính được số lần xuất hiện ạ.

Ví dụ như là em muốn tính vùng nào thì em chọn vùng đó rồi chạy code ạ

 

[mhung12005]

Dạ hàm hay code cũng được Anh , nhưng A2 đến A20 đó là em ví dụ thôi à, nó là tên người và nằm ở nhiều chổ khác nhau hết và dữ liệu đến 1 tháng lận nhiếu lắm, nên em muốn là vừa lấy được tên người ra và vừa tính được số lần xuất hiện ạ.

Ví dụ như là em muốn tính vùng nào thì em chọn vùng đó rồi chạy code ạ

Bạn thử code này xem thế nào rồi tính tiếp:

Sub test()
Dim Cel As Range
Dim Dic As Object
Dim strTam As String
Dim k As Long
Dim arrKetQua()
ReDim arrKetQua(1 To Selection.Rows.Count * Selection.Columns.Count, 1 To 2)
Set Dic = CreateObject("Scripting.Dictionary")
For Each Cel In Selection
    If Len(Cel.Value) Then
        strTam = CStr(Cel.Value)
        If Not Dic.exists(strTam) Then
            k = k + 1
            Dic.Add strTam, Array(k, 1)
            arrKetQua(k, 1) = strTam
            arrKetQua(k, 2) = Dic.Item(strTam)(1)
        Else
            Dic.Item(strTam) = Array(Dic.Item(strTam)(0), Dic.Item(strTam)(1) + 1)
            arrKetQua(Dic.Item(strTam)(0), 2) = Dic.Item(strTam)(1)
        End If
    End If
Next Cel
If k Then Sheet2.Range("B2").Resize(k, 2).Value = arrKetQua
End Sub

Select vùng cần đếm rồi chạy code.

 

[hungdiep85]

Bạn thử code này xem thế nào rồi tính tiếp:

Sub test()
Dim Cel As Range
Dim Dic As Object
Dim strTam As String
Dim k As Long
Dim arrKetQua()
ReDim arrKetQua(1 To Selection.Rows.Count * Selection.Columns.Count, 1 To 2)
Set Dic = CreateObject("Scripting.Dictionary")
For Each Cel In Selection
    If Len(Cel.Value) Then
        strTam = CStr(Cel.Value)
        If Not Dic.exists(strTam) Then
            k = k + 1
            Dic.Add strTam, Array(k, 1)
            arrKetQua(k, 1) = strTam
            arrKetQua(k, 2) = Dic.Item(strTam)(1)
        Else
            Dic.Item(strTam) = Array(Dic.Item(strTam)(0), Dic.Item(strTam)(1) + 1)
            arrKetQua(Dic.Item(strTam)(0), 2) = Dic.Item(strTam)(1)
        End If
    End If
Next Cel
If k Then Sheet2.Range("B2").Resize(k, 2).Value = arrKetQua
End Sub

Select vùng cần đếm rồi chạy code.

Dạ.Em cảm ơn Anh nhiều lắm. tuyệt vời Anh ạ.