Nhờ viết giúp code lọc số (1 người xem)

[totoha]

Em có bảng tính dữ liệu như file đính kèm
nội dung em cần làm như sau:
đếm số lần xuất hiện cái số từ 00-99 ở từng hàng từ cộtAD đến BD
với điều kiện
Nếu số đó xuất hiện =2 lần thì trả về số đó +**( 28**)
Nếu số đó xuất hiện =3 lần thì trả về số đó +***(28***)
Nếu số đó xuất hiện =4 lần thì trả về số đó +***(28****)
Kết quả trả về các số xuất hiện ở ô BE và các ô tiếp theo cũng hàng
Lưu ý: đến số lần xuất hiện trong từ hàng

 

[Let'GâuGâu]

Em có bảng tính dữ liệu như file đính kèm
Giờ em muốn lọc dữ liệu từ cột “AD” đến cột “BD” các số từ 00-99 xuất hiện bao nhiêu lần nếu nó lớn hơn 2 thì trả về số đó cộng với hai sô “**”. Các dữ liệu trả về đó được lưu tiếp vào cột “BE” và cũng vào một dòng
Ví dụ số 12 ,57xuất hiện 2 lần thì trả về: 12** lưu vào BE và 57** lưu vào BF
và cứ như vậy cho hết dữ liệu

thống kê từng hàng hay làm cho tất cả các hàng?
cái này là làm cho tất cả các hàng
[AD1:BD1744]

Sub demtrung()
Dim ng As Variant, kq(), i, j, k As Long, d As Object
ng = [AD1:BD1744].Value
Set d = CreateObject("Scripting.Dictionary")
For j = 1 To UBound(ng)
For i = 1 To UBound(ng, 2)
If Not d.exists(ng(j, i)) Then
    k = k + 1
    d.Add ng(j, i), k
    ReDim Preserve kq(1 To k)
    kq(k) = 1
Else
    kq(d.Item(ng(1, i))) = kq(d.Item(ng(1, i))) + 1
End If
Next
Next j

For Each v In d.Keys
n = n + 1
    kq(n) = v & Format(kq(n), "00")
Next v
Set d = Nothing
[BE1].Resize(, k).Value = kq

End Sub

 

[totoha]

thống kê từng hàng hay làm cho tất cả các hàng?
cái này là làm cho tất cả các hàng
[AD1:BD1744]

Sub demtrung()
Dim ng As Variant, kq(), i, j, k As Long, d As Object
ng = [AD1:BD1744].Value
Set d = CreateObject("Scripting.Dictionary")
For j = 1 To UBound(ng)
For i = 1 To UBound(ng, 2)
If Not d.exists(ng(j, i)) Then
    k = k + 1
    d.Add ng(j, i), k
    ReDim Preserve kq(1 To k)
    kq(k) = 1
Else
    kq(d.Item(ng(1, i))) = kq(d.Item(ng(1, i))) + 1
End If
Next
Next j

For Each v In d.Keys
n = n + 1
    kq(n) = v & Format(kq(n), "00")
Next v
Set d = Nothing
[BE1].Resize(, k).Value = kq

End Sub

cái này em làm cho từng hàng một
cái này e có ý định dùng hàm countif để đếm số lần xuất hiện nhưng ở đây điều kiện đếm từ 00-99 nên e muốn nhờ viết vba cho nhanh
với lại trả về kết quả chỉ có những số xuất hiện trên 2 lần thôi trong cùng 1 cột

 

[Let'GâuGâu]

cái này em làm cho từng hàng một

vậy thì thử cái này

Function DemTrung(rng As Range, col)
Dim ng As Variant, kq(), i, j, k As Long, d As Object
ng = rng.Value
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(ng, 2)
If Not d.exists(ng(1, i)) Then
    k = k + 1
    d.Add ng(1, i), k
    ReDim Preserve kq(1 To k)
    kq(k) = 1
Else
    kq(d.Item(ng(1, i))) = kq(d.Item(ng(1, i))) + 1
End If
Next

For Each v In d.Keys
n = n + 1
    kq(n) = v & Format(kq(n), "00")
Next v
Set d = Nothing

DemTrung = kq(col)
End Function

tại

BE1=DemTrung($AD1:$BD1,COLUMN()-56)

kéo qua phải, kéo xuống

 

[Ba Tê]

cái này em làm cho từng hàng một

Thà làm 1 bảng kết quả mẫu, có vài kết quả đúng để người ta còn hiểu mình muốn gì.
Nhiều người tiết kiệm "kỳ" thật.
Thử như vầy không đúng thì chạy.

 

[totoha]

Thà làm 1 bảng kết quả mẫu, có vài kết quả đúng để người ta còn hiểu mình muốn gì.
Nhiều người tiết kiệm "kỳ" thật.
Thử như vầy không đúng thì chạy.

Đúng rồi em ý em muốn là như của bác đó
như ở đây có mấy số xuất hiện 3 lần em muốn 3 lần thì có 3*, xuất hiện 4 lần thì có 4*

Thank bác nhiều

 

[Let'GâuGâu]

Đúng rồi em ý em muốn là như của bác đó
như ở đây có mấy số xuất hiện 3 lần em muốn 3 lần thì có 3*, xuất hiện 4 lần thì có 4*

Thank bác nhiều

lỡ làm rùi spam một chút

Function DemTrung(rng As Range, col)
Dim ng As Variant, tam(), kq(), i, j, k As Long, d As Object
ng = rng.Value
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(ng, 2)
If Not d.exists(ng(1, i)) Then
    k = k + 1
    d.Add ng(1, i), k
    ReDim Preserve tam(1 To k)
    tam(k) = 1
Else
    tam(d.Item(ng(1, i))) = tam(d.Item(ng(1, i))) + 1
End If
Next

For n = 1 To UBound(tam)
If tam(n) > 1 Then
    m = m + 1
    ReDim Preserve kq(1 To m)
    kq(m) = d.Keys()(n - 1) & "*" & Format(tam(n), "00")
End If
Next
Set d = Nothing

DemTrung = kq(col)
End Function

BE1=DemTrung($AD1:$BD1,COLUMN()-56)

 

[totoha]

lỡ làm rùi spam một chút

Function DemTrung(rng As Range, col)
Dim ng As Variant, tam(), kq(), i, j, k As Long, d As Object
ng = rng.Value
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(ng, 2)
If Not d.exists(ng(1, i)) Then
    k = k + 1
    d.Add ng(1, i), k
    ReDim Preserve tam(1 To k)
    tam(k) = 1
Else
    tam(d.Item(ng(1, i))) = tam(d.Item(ng(1, i))) + 1
End If
Next

For n = 1 To UBound(tam)
If tam(n) > 1 Then
    m = m + 1
    ReDim Preserve kq(1 To m)
    kq(m) = d.Keys()(n - 1) & "*" & Format(tam(n), "00")
End If
Next
Set d = Nothing

DemTrung = kq(col)
End Function

BE1=DemTrung($AD1:$BD1,COLUMN()-56)

Em hỏi bác tí
cái này em coppy vào vba chạy nhưng không thấy sub để chạy nó và ý bác là chỗ

[COLOR=#000000]BE1=DemTrung($AD1:$BD1,COLUMN()-56)[/COLOR]

là điền trực tiếp vào ô BE 1 bằng cái đó ahf

 

[Let'GâuGâu]

Em hỏi bác tí
cái này em coppy vào vba chạy nhưng không thấy sub để chạy nó và ý bác là chỗ

[COLOR=#000000]BE1=DemTrung($AD1:$BD1,COLUMN()-56)[/COLOR]

là điền trực tiếp vào ô BE 1 bằng cái đó ahf

đúng rồi chép cthuc đó vào cel BE1 kéo qua phải, kéo xuống
(hàm tự tạo)

 

[totoha]

đúng rồi chép cthuc đó vào cel BE1 kéo qua phải, kéo xuống
(hàm tự tạo)

nó báo lỗi
Em đã copy code vào modul VBA rồi làm đúng như vậy nó bao lỗi

 

[Let'GâuGâu]

nó báo lỗi
Em đã copy code vào modul VBA rồi làm đúng như vậy nó bao lỗi

thử lại xem.............................................................

 

[VetMini]

Bài này chỉ giản dị đếm từ 0 đến 99 thôi. Đâu cần phải đích điếc mệt lắm. Có nhanh chậm cũng chớp mắt là hết.

Sub t()
[COLOR=#008000]' đếm số lần lặp lại của các số từ 00 đến 99[/COLOR]
Dim vung As Range, cot As Range
Dim dem As Integer, i As Integer, nxt As Integer
Set cot = Range("BE:BE") [COLOR=#008000]' nơi ghi kết quả[/COLOR]
Set vung = Range("AD1:BD1744") [COLOR=#008000]' vùng dữ liệu cần đếm[/COLOR]
nxt = 0
For i = 0 To 99
       dem = Application.CountIf(vung, Format(i, "00"))
       If dem > 1 Then
             nxt = nxt + 1
             cot.Cells(nxt).Value = Format(i, "00") & "*" & dem
       End If
Next i
Set vung = Nothing
Set cot = Nothing
End Sub

 

[totoha]

thử lại xem.............................................................

được rồi ah
Thank anh
A giúp em làm cái giống như Bác gì vừa làm được không nội dung thì tương tự vậy
Nội dung thì được nhưng hàm của em dùng tiếp theo sử dụng theo số hiện thị và số ** rồi

 

[Let'GâuGâu]

được rồi ah
Thank anh
A giúp em làm cái giống như Bác gì vừa làm được không nội dung thì tương tự vậy
Nội dung thì được nhưng hàm của em dùng tiếp theo sử dụng theo số hiện thị và số ** rồi

bạn nên nhờ bác ấy giúp bạn luôn, code ai người đó dể sửa
goodnight

 

[Ba Tê]

Em có bảng tính dữ liệu như file đính kèm
nội dung em cần làm như sau:
đếm số lần xuất hiện cái số từ 00-99 ở từng hàng từ cộtAD đến BD
với điều kiện
Nếu số đó xuất hiện =2 lần thì trả về số đó +**( 28**)
Nếu số đó xuất hiện =3 lần thì trả về số đó +***(28***)
Nếu số đó xuất hiện =4 lần thì trả về số đó +***(28****)
Kết quả trả về các số xuất hiện ở ô BE và các ô tiếp theo cũng hàng
Lưu ý: đến số lần xuất hiện trong từ hàng

Làm rồi lại đổi yêu cầu là sao ta?

Public Sub QuaiQuai()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, Tem As Variant, MaxCol As Long
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range([AD1], [BD65536].End(xlUp)).Value2
ReDim dArr(1 To UBound(sArr, 1), 1 To 100)
For I = 1 To UBound(sArr, 1)
    K = 0
    For J = 1 To UBound(sArr, 2)
        Tem = sArr(I, J)
        If Not Dic.exists(Tem) Then
            Dic.Add Tem, Tem & "*"
        Else
            Dic.Item(Tem) = Dic.Item(Tem) & "*"
        End If
    Next J
    For Each Tem In Dic.Items
        If Right(Tem, 2) = "**" Then
            K = K + 1
            dArr(I, K) = Tem
        End If
        If K > MaxCol Then MaxCol = K
    Next Tem
    Dic.RemoveAll
Next I
[BE1].Resize(I - 1, MaxCol) = dArr
Set Dic = Nothing
End Sub