[Cần giúp đỡ] Xin hỏi về cách lấy các số liệu xuất hiện nhiều nhất

NguyenVietThinh08 · 8/11/20

Lời đầu tiên em xin cảm ơn các anh chị trên diễn dàn đã rất nhiệt tình trả lời câu hỏi, em là một tay mơ mới học VBA và càng học thì lại càng xuất hiện nhiều bài toán, có nhiều bài toán cũng đã giải được, tuy nhiên nhiều bài vẫn chưa biết cách làm, do vậy rất mong các anh chị em trên diễn đàn chỉ giúp ạ,
Em có bài toán muốn được anh chị chỉ giùm, em có 1 cột dữ liệu gồm các giá trị có thể lặp lại nhiều lần, em muốn tìm ra các giá trị xuất hiện nhiều nhất và tự động điền vào cột bên cạnh theo tần xuất, Rất mong các anh chị chỉ giùm em.. Em xin cảm ơn ạ

snow25 · 9/11/20

Nguyenvthe đã viết:
Lời đầu tiên em xin cảm ơn các anh chị trên diễn dàn đã rất nhiệt tình trả lời câu hỏi, em là một tay mơ mới học VBA và càng học thì lại càng xuất hiện nhiều bài toán, có nhiều bài toán cũng đã giải được, tuy nhiên nhiều bài vẫn chưa biết cách làm, do vậy rất mong các anh chị em trên diễn đàn chỉ giúp ạ,
Em có bài toán muốn được anh chị chỉ giùm, em có 1 cột dữ liệu gồm các giá trị có thể lặp lại nhiều lần, em muốn tìm ra các giá trị xuất hiện nhiều nhất và tự động điền vào cột bên cạnh theo tần xuất, Rất mong các anh chị chỉ giùm em.. Em xin cảm ơn ạ

Bạn thử code này xem.

Mã:

Sub dem()
   Dim i As Long, lr As Long, dic As Object, kq, arr, b As Long, dk As String, a As Long, j As Long
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("sheet1")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A1:A" & lr).Value
        ReDim kq(1 To UBound(arr) + 5, 1 To 2)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = dk
               kq(a, 2) = 1
            Else
               b = dic.Item(dk)
               kq(b, 2) = kq(b, 2) + 1
            End If
        Next i
        For i = 1 To a
            For j = a To 2 Step -1
                If kq(j, 2) > kq(j - 1, 2) Then
                   dk = kq(j, 1)
                   b = kq(j, 2)
                   kq(j, 2) = kq(j - 1, 2)
                   kq(j, 1) = kq(j - 1, 1)
                   kq(j - 1, 2) = b
                   kq(j - 1, 1) = dk
                 End If
           Next j
       Next i
       .Range("F2:G6").Value = kq
   End With
End Sub

be_09 · 9/11/20

Nguyenvthe đã viết:
Lời đầu tiên em xin cảm ơn các anh chị trên diễn dàn đã rất nhiệt tình trả lời câu hỏi, em là một tay mơ mới học VBA và càng học thì lại càng xuất hiện nhiều bài toán, có nhiều bài toán cũng đã giải được, tuy nhiên nhiều bài vẫn chưa biết cách làm, do vậy rất mong các anh chị em trên diễn đàn chỉ giúp ạ,
Em có bài toán muốn được anh chị chỉ giùm, em có 1 cột dữ liệu gồm các giá trị có thể lặp lại nhiều lần, em muốn tìm ra các giá trị xuất hiện nhiều nhất và tự động điền vào cột bên cạnh theo tần xuất, Rất mong các anh chị chỉ giùm em.. Em xin cảm ơn ạ

Có thể sử dụng PivotTable rồi Filter.

Nhattanktnn · 9/11/20

Nguyenvthe đã viết:
Lời đầu tiên em xin cảm ơn các anh chị trên diễn dàn đã rất nhiệt tình trả lời câu hỏi, em là một tay mơ mới học VBA và càng học thì lại càng xuất hiện nhiều bài toán, có nhiều bài toán cũng đã giải được, tuy nhiên nhiều bài vẫn chưa biết cách làm, do vậy rất mong các anh chị em trên diễn đàn chỉ giúp ạ,
Em có bài toán muốn được anh chị chỉ giùm, em có 1 cột dữ liệu gồm các giá trị có thể lặp lại nhiều lần, em muốn tìm ra các giá trị xuất hiện nhiều nhất và tự động điền vào cột bên cạnh theo tần xuất, Rất mong các anh chị chỉ giùm em.. Em xin cảm ơn ạ

Thử:

PHP:

Option Explicit
Public Sub TopList()
    Const sList As Byte = 5
    Dim dict As Object, Key As Variant, I As Long, J As Long, K As Long, sArr(), dArr()
    Set dict = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        sArr = .Range("A1:A" & Cells(.Rows.Count, 1).End(xlUp).Row).Value
        ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
        For I = 1 To UBound(sArr, 1)
            If Not dict.exists(sArr(I, 1)) Then
                J = J + 1
                dict.Add (sArr(I, 1)), 1 + 0.1 / I
                dArr(J, 1) = J
            Else
                dict.Item(sArr(I, 1)) = dict.Item(sArr(I, 1)) + 1
            End If
        Next
        If J < sList Then MsgBox "Du lieu chi co " & J & " loai, khong du " & sList & " loai": Exit Sub
        For K = 1 To sList
            For Each Key In dict
                If dict(Key) = Application.Large(dict.Items, K) Then
                    dArr(K, 2) = Key: dArr(K, 3) = Int(dict(Key))
                End If
            Next
        Next
        .Range("E2").Resize(sList, 3) = dArr
    End With
Set dict = Nothing
End Sub

NguyenVietThinh08 · 9/11/20

snow25 đã viết:

Bạn thử code này xem.

Mã:

Sub dem()
   Dim i As Long, lr As Long, dic As Object, kq, arr, b As Long, dk As String, a As Long, j As Long
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("sheet1")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A1:A" & lr).Value
        ReDim kq(1 To UBound(arr) + 5, 1 To 2)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = dk
               kq(a, 2) = 1
            Else
               b = dic.Item(dk)
               kq(b, 2) = kq(b, 2) + 1
            End If
        Next i
        For i = 1 To a
            For j = a To 2 Step -1
                If kq(j, 2) > kq(j - 1, 2) Then
                   dk = kq(j, 1)
                   b = kq(j, 2)
                   kq(j, 2) = kq(j - 1, 2)
                   kq(j, 1) = kq(j - 1, 1)
                   kq(j - 1, 2) = b
                   kq(j - 1, 1) = dk
                 End If
           Next j
       Next i
       .Range("F2:G6").Value = kq
   End With
End Sub

Nhattanktnn đã viết:

Thử:

PHP:

Option Explicit
Public Sub TopList()
    Const sList As Byte = 5
    Dim dict As Object, Key As Variant, I As Long, J As Long, K As Long, sArr(), dArr()
    Set dict = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        sArr = .Range("A1:A" & Cells(.Rows.Count, 1).End(xlUp).Row).Value
        ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
        For I = 1 To UBound(sArr, 1)
            If Not dict.exists(sArr(I, 1)) Then
                J = J + 1
                dict.Add (sArr(I, 1)), 1 + 0.1 / I
                dArr(J, 1) = J
            Else
                dict.Item(sArr(I, 1)) = dict.Item(sArr(I, 1)) + 1
            End If
        Next
        If J < sList Then MsgBox "Du lieu chi co " & J & " loai, khong du " & sList & " loai": Exit Sub
        For K = 1 To sList
            For Each Key In dict
                If dict(Key) = Application.Large(dict.Items, K) Then
                    dArr(K, 2) = Key: dArr(K, 3) = Int(dict(Key))
                End If
            Next
        Next
        .Range("E2").Resize(sList, 3) = dArr
    End With
Set dict = Nothing
End Sub

Cảm ơn bác nhiều, Hàm thành công ạ

Bài đã được tự động gộp: 9/11/20

snow25 đã viết:

Bạn thử code này xem.

Mã:

Sub dem()
   Dim i As Long, lr As Long, dic As Object, kq, arr, b As Long, dk As String, a As Long, j As Long
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("sheet1")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A1:A" & lr).Value
        ReDim kq(1 To UBound(arr) + 5, 1 To 2)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = dk
               kq(a, 2) = 1
            Else
               b = dic.Item(dk)
               kq(b, 2) = kq(b, 2) + 1
            End If
        Next i
        For i = 1 To a
            For j = a To 2 Step -1
                If kq(j, 2) > kq(j - 1, 2) Then
                   dk = kq(j, 1)
                   b = kq(j, 2)
                   kq(j, 2) = kq(j - 1, 2)
                   kq(j, 1) = kq(j - 1, 1)
                   kq(j - 1, 2) = b
                   kq(j - 1, 1) = dk
                 End If
           Next j
       Next i
       .Range("F2:G6").Value = kq
   End With
End Sub

Dạ chạy ngon ạ, em cảm ơn bác nhiều

Yugihero · 13/11/20

Bài đã được tự động gộp: 13/11/20

be09 đã viết:
Có thể sử dụng PivotTable rồi Filter.

chào anh beo9 ạ. anh có thể cho e xin sdt or zalo của anh được k ạ. e cảm ơn

be_09 · 13/11/20

Yugihero đã viết:
Bài đã được tự động gộp: 13/11/20

chào anh beo9 ạ. anh có thể cho e xin sdt or zalo của anh được k ạ. e cảm ơn

Sao em không nêu số điện thoại của em hoặc Zalo.
Bài viết nên viết chữ đầy đủ, rỏ ràng, không nên viết tắt.

hungtin1997 · 13/11/20

Nguyenvthe đã viết:
Lời đầu tiên em xin cảm ơn các anh chị trên diễn dàn đã rất nhiệt tình trả lời câu hỏi, em là một tay mơ mới học VBA và càng học thì lại càng xuất hiện nhiều bài toán, có nhiều bài toán cũng đã giải được, tuy nhiên nhiều bài vẫn chưa biết cách làm, do vậy rất mong các anh chị em trên diễn đàn chỉ giúp ạ,
Em có bài toán muốn được anh chị chỉ giùm, em có 1 cột dữ liệu gồm các giá trị có thể lặp lại nhiều lần, em muốn tìm ra các giá trị xuất hiện nhiều nhất và tự động điền vào cột bên cạnh theo tần xuất, Rất mong các anh chị chỉ giùm em.. Em xin cảm ơn ạ

Bác thử xem nhé. Ngắn thôi
Cột kế bên nguồn là cột tần suất, cột tiếp theo nữa là giá trị ô lặp lại.
Code hơi cùi do chưa rành lắm về mảng.

Mã:

Sub gpe()
Set o = Application.InputBox("Chon vung can dem", "Thông báo", Type:=8)
ReDim arr(1 To o.Rows.Count, 1 To 3)
For i = 1 To UBound(arr, 1)
     arr(i, 1) = Application.WorksheetFunction.CountIf(Range(o(1, 1), o(i, 1)), o(i, 1))
     arr(i, 2) = o(i, 1)
Next
Range(o(1, 2), o(UBound(arr, 1), 3)) = arr
Range(o(1, 2), o(UBound(arr, 1), 3)).Sort key1:=Range(o(1, 2), o(UBound(arr, 1), 3)), order1:=xlDescending, MatchCase:=False
Range(o(1, 2), o(UBound(arr, 1), 3)).RemoveDuplicates Columns:=2, Header:=xlNo
End Sub

Yugihero · 14/11/20

be09 đã viết:
Sao em không nêu số điện thoại của em hoặc Zalo.
Bài viết nên viết chữ đầy đủ, rỏ ràng, không nên viết tắt.

be09 đã viết:

Sao em không nêu số điện thoại của em hoặc Zalo.
Bài viết nên viết chữ đầy đủ, rỏ ràng, không nên viết tắt

Nhấp chuột vào đây để mở rộng...

dạ zalo em 0914807345 mong đc a ib ạ. cảm ơn anh nhiều

NguyenVietThinh08 · 14/11/20

hungtin1997 đã viết:
Bác thử xem nhé. Ngắn thôi
Cột kế bên nguồn là cột tần suất, cột tiếp theo nữa là giá trị ô lặp lại.
Code hơi cùi do chưa rành lắm về mảng.

Mã:

Sub gpe() Set o = Application.InputBox("Chon vung can dem", "Thông báo", Type:=8) ReDim arr(1 To o.Rows.Count, 1 To 3) For i = 1 To UBound(arr, 1) arr(i, 1) = Application.WorksheetFunction.CountIf(Range(o(1, 1), o(i, 1)), o(i, 1)) arr(i, 2) = o(i, 1) Next Range(o(1, 2), o(UBound(arr, 1), 3)) = arr Range(o(1, 2), o(UBound(arr, 1), 3)).Sort key1:=Range(o(1, 2), o(UBound(arr, 1), 3)), order1:=xlDescending, MatchCase:=False Range(o(1, 2), o(UBound(arr, 1), 3)).RemoveDuplicates Columns:=2, Header:=xlNo End Sub

vâng, cảm ơn bác ạ, em sẽ thử

NguyenVietThinh08 · 15/11/20

Nguyenvthe đã viết:
Cảm ơn bác nhiều, Hàm thành công ạ

Bài đã được tự động gộp: 9/11/20

Dạ chạy ngon ạ, em cảm ơn bác nhiều

Hàm của bác chạy đúng ý em ạ, nhưng mà mấy hôm nay em cố gắng hiểu code của bác mà vẫn mông lung quá, bác có thể đính kèm giải thích sang bên cạnh giúp em được không ạ, em cảm ơn bác nhiều ạ

hungtin1997 · 16/11/20

Nguyenvthe đã viết:
Hàm của bác chạy đúng ý em ạ, nhưng mà mấy hôm nay em cố gắng hiểu code của bác mà vẫn mông lung quá, bác có thể đính kèm giải thích sang bên cạnh giúp em được không ạ, em cảm ơn bác nhiều ạ

Anh viết vậy làm sao mọi người biết anh hỏi ai? =((((

VetMini · 16/11/20

hungtin1997 đã viết:
Anh viết vậy làm sao mọi người biết anh hỏi ai? =((((

Hỏi cái người "đúng ý".
Ai tự tin rằng mình "đúng ý" thớt thì trả lời. Ai không tự tin thì chịu khó ngồi ngó, chờ người tự tin kia thất bại thì lại xen vào.
Loại bài này hôm nay đúng, ngày mai sai là bình thường.

Cu Tồ · 17/11/20

VetMini đã viết:
Ai tự tin rằng mình "đúng ý" thớt

Thì có xin số điện thoại và zalo đó Bác

NguyenVietThinh08 · 17/11/20

hungtin1997 đã viết:
Anh viết vậy làm sao mọi người biết anh hỏi ai? =((((

chắc gộp bài hoặc mình k để ý, sau 2 ngày mày mò mình cũng đã hiểu rồi bạn ạ,

NguyenVietThinh08 · 17/11/20

VetMini đã viết:
Hỏi cái người "đúng ý".
Ai tự tin rằng mình "đúng ý" thớt thì trả lời. Ai không tự tin thì chịu khó ngồi ngó, chờ người tự tin kia thất bại thì lại xen vào.
Loại bài này hôm nay đúng, ngày mai sai là bình thường.

Dạ chào bác Mini, em đang học Mảng trong VBA, dạ em lại đang phát sinh điều mới cần học hỏi, phiền bác giúp em, Giả sử em có sheet1, A1 đến A5 (1,2,3,4,5) em đặt là mảng 1 Arr1( 1 to5) cột 2 là từ D2 đến D6 (a,b,c,d,e,f) em đặt là mảng Arr2(1 to 5), Bây giờ có các nào em ghép 2 mảng ngày với nhau tạo thành mảng Arr( 1 to 5, 1 to 5) với các chiều thứ nhất là mảng Arr1, chiều thứ 2 là mảng Arr2, (1,2,3,4,5; a, b, c, d, e, f). bác giúp em được không ạ

[Cần giúp đỡ] Xin hỏi về cách lấy các số liệu xuất hiện nhiều nhất

NguyenVietThinh08

Thành viên chính thức

File đính kèm

snow25

Thành viên gạo cội

be_09

Biên Hòa, Đồng Nai

File đính kèm

Nhattanktnn

Thành viên gắn bó

NguyenVietThinh08

Thành viên chính thức

Yugihero

Thành viên mới

be_09

Biên Hòa, Đồng Nai

hungtin1997

Dậm chân tại chỗ là đi lùi

Yugihero

Thành viên mới

NguyenVietThinh08

Thành viên chính thức

NguyenVietThinh08

Thành viên chính thức

hungtin1997

Dậm chân tại chỗ là đi lùi

VetMini

Ăn cùng góc phố

Cu Tồ

Tìm đến kiến thức! ꧁༺ Cu Tồ ༻꧂

NguyenVietThinh08

Thành viên chính thức

NguyenVietThinh08

Thành viên chính thức

Bài viết mới nhất

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