giúp code lọc tên hàng không trùng, và đếm số lần xuất hiện

Liên hệ QC
H

hunglam123

Thành viên bị đình chỉ hoạt động
Thành viên bị đình chỉ hoạt động
Tham gia
31/3/20
Bài viết
180
Được thích
43
Chào cả nhà GPE !
em cần 1 đoạn code lọc ra các tên hàng không trùng và đếm số lần xuất hiện. Xin chân thành cảm ơn

1592031163800.png
 

File đính kèm

  • gpe.xlsx
    10.1 KB · Đọc: 25
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Code:
Cái này là căn bản đít sần nè. Bà con ai muốn học đít sần thì nhào vào thử đi.
(Nếu muốn lập trình lý thuyết căn bản thì dùng giải thuật sắp xếp)

Không code:
Cái này là căn bản quản lý nè. Bà con ai nghĩ mình có khiếu quản lý thì thử đi.

Một cơ hội học luôn 3 cản bản.
 
Upvote 0
Upvote 0
Hoàng Tuấn 868 đã viết:
Bạn quên mất phần nội quy là không được viết chữ in cả câu rồi: "GIÚP CODE LỌC TÊN HÀNG KHÔNG TRÙNG". Nên sửa lại nhé.
Nhấp chuột vào đây để mở rộng...
Thường đâu có kể gì nội quy hay người khác. Cách làm việc nào giờ là nói khích cho người ta làm giùm thôi.
Có code rồi sẽ có câu: "đơn giản, mười [mấy] dòng là xong"
 
Upvote 0
Bạn thử Sub sau nhưng kết quả của A là 6 nên không hiểu cách thống kê của bạn
Mã: 
Sub DemTong()
Dim i As Long, aDuLieu(), aKetQua(), Dic As Object, k As Long, J As Long, DieuKien As Variant
Set Dic = CreateObject("Scripting.Dictionary")
aDuLieu = Sheet1.Range("B3:B" & Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row).Value
    ReDimaKetQua(1 To UBound(aDuLieu, 1), 1 To 2)
  For i = 1 To UBound(aDuLieu, 1)
    DieuKien = aDuLieu(i, 1)
    If Dic.Exists(DieuKien) = False Then
        k = k + 1
        Dic.Add DieuKien, k
       aKetQua(k, 1) = aDuLieu(i, 1)
       aKetQua(k, 2) = 1
    Else
        J = Dic.Item(DieuKien)
       aKetQua(J, 2) = aKetQua(J, 2) + 1
    End If
   Next
Sheet1.Range("D3:E10000").ClearContents
If k <> 0 Then Sheet1.Range("D3").Resize(k, 2).Value = aKetQua
End Sub
 
Upvote 0
vanaccex đã viết:
Bạn thử Sub sau nhưng kết quả của A là 6 nên không hiểu cách thống kê của bạn
Mã: 
Sub DemTong()
Dim i As Long, aDuLieu(), aKetQua(), Dic As Object, k As Long, J As Long, DieuKien As Variant
Set Dic = CreateObject("Scripting.Dictionary")
aDuLieu = Sheet1.Range("B3:B" & Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row).Value
    ReDimaKetQua(1 To UBound(aDuLieu, 1), 1 To 2)
  For i = 1 To UBound(aDuLieu, 1)
    DieuKien = aDuLieu(i, 1)
    If Dic.Exists(DieuKien) = False Then
        k = k + 1
        Dic.Add DieuKien, k
       aKetQua(k, 1) = aDuLieu(i, 1)
       aKetQua(k, 2) = 1
    Else
        J = Dic.Item(DieuKien)
       aKetQua(J, 2) = aKetQua(J, 2) + 1
    End If
   Next
Sheet1.Range("D3:E10000").ClearContents
If k <> 0 Then Sheet1.Range("D3").Resize(k, 2).Value = aKetQua
End Sub
Nhấp chuột vào đây để mở rộng...
COde báo lỗi rồi SẾp ơi
 
Upvote 0
vanaccex đã viết:
Dòng này
Mã: 
ReDimaKetQua(1 To UBound(aDuLieu, 1), 1 To 2)
Sửa thành
Mã: 
ReDim aKetQua(1 To UBound(aDuLieu, 1), 1 To 2)
Xem còn lỗi nữa không
Nhấp chuột vào đây để mở rộng...

sao nó dư 1 dòng cuối
1592031842137.png


Mã: 
Sub DemTong()
Dim i As Long, aDuLieu(), aKetQua(), Dic As Object, k As Long, J As Long, DieuKien As Variant
Set Dic = CreateObject("Scripting.Dictionary")
aDuLieu = Sheet1.Range("B3:B5000").Value
ReDim aKetQua(1 To UBound(aDuLieu, 1), 1 To 2)
  For i = 1 To UBound(aDuLieu, 1)
    DieuKien = aDuLieu(i, 1)
    If Dic.exists(DieuKien) = False Then
        k = k + 1
        Dic.Add DieuKien, k
       aKetQua(k, 1) = aDuLieu(i, 1)
       aKetQua(k, 2) = 1
    Else
        J = Dic.Item(DieuKien)
       aKetQua(J, 2) = aKetQua(J, 2) + 1
    End If
   Next
Range("D3:E10000").ClearContents
If k <> 0 Then Sheet1.Range("D3").Resize(k, 2).Value = aKetQua
End Sub
 
Upvote 0
hunglam123 đã viết:
sao nó dư 1 dòng cuối
View attachment 239217


Mã: 
Sub DemTong()
Dim i As Long, aDuLieu(), aKetQua(), Dic As Object, k As Long, J As Long, DieuKien As Variant
Set Dic = CreateObject("Scripting.Dictionary")
aDuLieu = Sheet1.Range("B3:B5000").Value
ReDim aKetQua(1 To UBound(aDuLieu, 1), 1 To 2)
  For i = 1 To UBound(aDuLieu, 1)
    DieuKien = aDuLieu(i, 1)
    If Dic.exists(DieuKien) = False Then
        k = k + 1
        Dic.Add DieuKien, k
       aKetQua(k, 1) = aDuLieu(i, 1)
       aKetQua(k, 2) = 1
    Else
        J = Dic.Item(DieuKien)
       aKetQua(J, 2) = aKetQua(J, 2) + 1
    End If
   Next
Range("D3:E10000").ClearContents
If k <> 0 Then Sheet1.Range("D3").Resize(k, 2).Value = aKetQua
End Sub
Nhấp chuột vào đây để mở rộng...
Vùng dữ liệu nếu bạn đặt thế kia thì thì thêm 1 điều kiện khác rỗng vào
 
Upvote 0
Code bài #8 có mang một dấu ấn "GPE" tổ bố:
- Code dùng mảng đầu vào riêng biệt với mảng đầu ra chỉnh chu. Chỉ có dân code của GPE mới làm kiểu đó thôi.
Trong đề bài này, đầu ra không thể lớn hơn đầu vào. Vì vậy, một mảng đầu vào có thể dùng lại thành đầu ra.
 
Upvote 0
hunglam123 đã viết:
sao nó dư 1 dòng cuối
View attachment 239217


Mã: 
Sub DemTong()
Dim i As Long, aDuLieu(), aKetQua(), Dic As Object, k As Long, J As Long, DieuKien As Variant
Set Dic = CreateObject("Scripting.Dictionary")
aDuLieu = Sheet1.Range("B3:B5000").Value
ReDim aKetQua(1 To UBound(aDuLieu, 1), 1 To 2)
  For i = 1 To UBound(aDuLieu, 1)
    DieuKien = aDuLieu(i, 1)
    If Dic.exists(DieuKien) = False Then
        k = k + 1
        Dic.Add DieuKien, k
       aKetQua(k, 1) = aDuLieu(i, 1)
       aKetQua(k, 2) = 1
    Else
        J = Dic.Item(DieuKien)
       aKetQua(J, 2) = aKetQua(J, 2) + 1
    End If
   Next
Range("D3:E10000").ClearContents
If k <> 0 Then Sheet1.Range("D3").Resize(k, 2).Value = aKetQua
End Sub
Nhấp chuột vào đây để mở rộng...
Thử thay:
PHP: 
If k <> 0 Then Sheet1.Range("D3").Resize(k, 2).Value = aKetQua

bằng;
PHP: 
If k <> 0 Then Sheet1.Range("D3").Resize(k - 1, 2).Value = aKetQua
 
Upvote 0
phulien1902 đã viết:
Thử thay:
PHP: 
If k <> 0 Then Sheet1.Range("D3").Resize(k, 2).Value = aKetQua

bằng;
PHP: 
If k <> 0 Then Sheet1.Range("D3").Resize(k - 1, 2).Value = aKetQua
Nhấp chuột vào đây để mở rộng...

cảm ơn bạn
Mã: 
Sub LocTrungdem()
On Error Resume Next
Range("D3:E10000").ClearContents
Dim i As Long, k As Long, t As Long
Dim sArr(), dArr()
Dim Dic As Object
Set Dic = CreateObject("Scripting.dictionary")
sArr = Range("B3:C200").Value 'input
ReDim dArr(1 To UBound(sArr), 1 To 2)
For i = 1 To UBound(sArr)

        If Not Dic.exists(sArr(i, 1)) Then
            k = k + 1
            Dic(sArr(i, 1)) = k
            dArr(k, 1) = sArr(i, 1): dArr(k, 2) = 1
        Else
            t = Dic.Item(sArr(i, 1))
            dArr(t, 2) = dArr(t, 2) + 1
        End If
 
Next
Range("d3").Resize(k - 1, 2) = dArr ' Ouput
Set Dic = Nothing
End Sub
Bài đã được tự động gộp:

VetMini đã viết:
Code bài #8 có mang một dấu ấn "GPE" tổ bố:
- Code dùng mảng đầu vào riêng biệt với mảng đầu ra chỉnh chu. Chỉ có dân code của GPE mới làm kiểu đó thôi.
Trong đề bài này, đầu ra không thể lớn hơn đầu vào. Vì vậy, một mảng đầu vào có thể dùng lại thành đầu ra.
Nhấp chuột vào đây để mở rộng...
đã xong
Mã: 
Sub LocTrungdem()
On Error Resume Next
Range("D3:E10000").ClearContents
Dim i As Long, k As Long, t As Long
Dim sArr(), dArr()
Dim Dic As Object
Set Dic = CreateObject("Scripting.dictionary")
sArr = Range("B3:C200").Value 'input
ReDim dArr(1 To UBound(sArr), 1 To 2)
For i = 1 To UBound(sArr)

        If Not Dic.exists(sArr(i, 1)) Then
            k = k + 1
            Dic(sArr(i, 1)) = k
            dArr(k, 1) = sArr(i, 1): dArr(k, 2) = 1
        Else
            t = Dic.Item(sArr(i, 1))
            dArr(t, 2) = dArr(t, 2) + 1
        End If
 
Next
Range("d3").Resize(k - 1, 2) = dArr ' Ouput
Set Dic = Nothing
End Sub
 
Upvote 0
VetMini đã viết:
Code bài #8 có mang một dấu ấn "GPE" tổ bố:
- Code dùng mảng đầu vào riêng biệt với mảng đầu ra chỉnh chu. Chỉ có dân code của GPE mới làm kiểu đó thôi.
Trong đề bài này, đầu ra không thể lớn hơn đầu vào. Vì vậy, một mảng đầu vào có thể dùng lại thành đầu ra.
Nhấp chuột vào đây để mở rộng...
Em Vân chưa đủ tầm làm dân code đó được anh ạ !
 
Upvote 0
hunglam123 đã viết:
cảm ơn bạn
Mã: 
Sub LocTrungdem()
On Error Resume Next
Range("D3:E10000").ClearContents
Dim i As Long, k As Long, t As Long
Dim sArr(), dArr()
Dim Dic As Object
Set Dic = CreateObject("Scripting.dictionary")
sArr = Range("B3:C200").Value 'input
ReDim dArr(1 To UBound(sArr), 1 To 2)
For i = 1 To UBound(sArr)

        If Not Dic.exists(sArr(i, 1)) Then
            k = k + 1
            Dic(sArr(i, 1)) = k
            dArr(k, 1) = sArr(i, 1): dArr(k, 2) = 1
        Else
            t = Dic.Item(sArr(i, 1))
            dArr(t, 2) = dArr(t, 2) + 1
        End If

Next
Range("d3").Resize(k - 1, 2) = dArr ' Ouput
Set Dic = Nothing
End Sub
Bài đã được tự động gộp:


đã xong
Mã: 
Sub LocTrungdem()
On Error Resume Next
Range("D3:E10000").ClearContents
Dim i As Long, k As Long, t As Long
Dim sArr(), dArr()
Dim Dic As Object
Set Dic = CreateObject("Scripting.dictionary")
sArr = Range("B3:C200").Value 'input
ReDim dArr(1 To UBound(sArr), 1 To 2)
For i = 1 To UBound(sArr)

        If Not Dic.exists(sArr(i, 1)) Then
            k = k + 1
            Dic(sArr(i, 1)) = k
            dArr(k, 1) = sArr(i, 1): dArr(k, 2) = 1
        Else
            t = Dic.Item(sArr(i, 1))
            dArr(t, 2) = dArr(t, 2) + 1
        End If

Next
Range("d3").Resize(k - 1, 2) = dArr ' Ouput
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Code chạy vẫn bị đếm các ô là rỗng anh ạ.
Bài đã được tự động gộp:

vanaccex đã viết:
Em Vân chưa đủ tầm làm dân code đó được anh ạ !
Nhấp chuột vào đây để mở rộng...
Vân viết code thế là giỏi lắm rồi, bao người chưa học được tới mức của Vân !!!
 
Upvote 0
vanaccex đã viết:
Em Vân chưa đủ tầm làm dân code đó được anh ạ !
Nhấp chuột vào đây để mở rộng...

Dùng 1 mảng:

Dim a As Variant, aNum As Long
Dim i As Long
' lưu ý: 2 cột
a = Range("B3:C" & Cells(Rows.Count, "B").End(xlUp).Row).Value
With CreateObject("Scripting.dictionary")
For i = 1 To UBound(a)
If a(i, 1) <> "" Then ' thớt mới thêm điều kiện này. Trước đó không có. File mẫu cũng không có
If Not .Exists(a(i, 1)) Then
aNum = aNum + 1 ' tổng số dòng kết quả
.Add (a(i, 1)), aNum
a(aNum, 1) = a(i, 1)
a(aNum, 2) = 1
Else
a(.Item(a(i, 1)), 2) = a(.Item(a(i, 1)), 2) + 1
End If
End If
Next i
End With
Range("D3").Resize(aNum, 2).Value = a

Dùng đít sần chỉ để đếm:
(lưu ý: Application.Transpose có giới hạn của nó. Khi dùng nên cẩn thận. Code chỉ có tính chất minh họa)

a = Range("B3:C" & Cells(Rows.Count, "B").End(xlUp).Row).Value
With CreateObject("Scripting.dictionary")
For i = 1 To UBound(a)
If a(i, 1) <> "" Then .Item(a(i, 1)) = .Item(a(i, 1)) + 1
Next i
Range("D3").Resize(.Count).Value = Application.Transpose(.Keys())
Range("E3").Resize(.Count).Value = Application.Transpose(.Items())
End With
 
Upvote 0
VetMini đã viết:
Dùng 1 mảng:

Dim a As Variant, aNum As Long
Dim i As Long
' lưu ý: 2 cột
a = Range("B3:C" & Cells(Rows.Count, "B").End(xlUp).Row).Value
With CreateObject("Scripting.dictionary")
For i = 1 To UBound(a)
If a(i, 1) <> "" Then ' thớt mới thêm điều kiện này. Trước đó không có. File mẫu cũng không có
If Not .Exists(a(i, 1)) Then
aNum = aNum + 1 ' tổng số dòng kết quả
.Add (a(i, 1)), aNum
a(aNum, 1) = a(i, 1)
a(aNum, 2) = 1
Else
a(.Item(a(i, 1)), 2) = a(.Item(a(i, 1)), 2) + 1
End If
End If
Next i
End With
Range("D3").Resize(aNum, 2).Value = a

Dùng đít sần chỉ để đếm:
(lưu ý: Application.Transpose có giới hạn của nó. Khi dùng nên cẩn thận. Code chỉ có tính chất minh họa)

a = Range("B3:C" & Cells(Rows.Count, "B").End(xlUp).Row).Value
With CreateObject("Scripting.dictionary")
For i = 1 To UBound(a)
If a(i, 1) <> "" Then .Item(a(i, 1)) = .Item(a(i, 1)) + 1
Next i
Range("D3").Resize(.Count).Value = Application.Transpose(.Keys())
Range("E3").Resize(.Count).Value = Application.Transpose(.Items())
End With
Nhấp chuột vào đây để mở rộng...
Tiết kiệm được 1 dòng Redim.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

F
  • Question
Nhờ tư vấn cách tạo QR trong Excel
Trả lời
6
Đọc
481
anhtuanle123
A
Tienvinh191
  • Question
Nhờ viết Code lấy dữ liệu tờ khai hải quan vào bảng tổng hợp
2
Trả lời
25
Đọc
2K
haott
H
H
Hỗ trợ lấy danh sách dữ liệu thỏa mãn điều kiện
Trả lời
2
Đọc
86
NT Ngoc Yen
N
hoaithanh9480
KIỂM PHIẾU BẦU ĐẠI HỘI ĐẢNG
    • Thích
    • Cười
Trả lời
0
Đọc
5
hoaithanh9480
hoaithanh9480
CodyPham97
tạo biểu tượng thay thế nhấn đúp chuột
Trả lời
4
Đọc
77
phansythao
phansythao
dovanha1994
Giúp e tìm nguyên nhân sai và hướng dẫn e đọc file này với ạ
    • Phẫn nộ
Trả lời
4
Đọc
114
SA_DQ
SA_DQ
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
10
Đọc
508
20050911
20050911
N
Giúp sửa mã code
2
Trả lời
20
Đọc
439
Nguyễn Diêu Hiền
N
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11/2024
    • Thích
    • Yêu thích
Trả lời
1
Đọc
82
SA_DQ
SA_DQ
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
32
Đọc
856
VetMini
V
K
Nhờ mọi người hoàn thiện giúp công thức
Trả lời
4
Đọc
103
kiendt1973
K
P
Nhờ giúp đỡ hàm lọc dữ liệu theo tỉnh
Trả lời
10
Đọc
169
Parabol
P
H
Chúc mừng 20/11- ngày tôn vinh nhà giáo Việt Nam.
    • Thích
    • Yêu thích
Trả lời
0
Đọc
62
HUONGHCKT
H
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
7
Đọc
196
Ny Ny 2024
N
Nhật Anh 9x
  • Question
Tính tồn cuối kỳ luỹ kế cho nhiều mã
Trả lời
2
Đọc
100
Nhật Anh 9x
Nhật Anh 9x
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
2
Trả lời
20
Đọc
581
ptm0412
ptm0412
nguyen trung cuong
File chứa marco không mở được.
Trả lời
2
Đọc
78
nguyen trung cuong
nguyen trung cuong
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
1
Đọc
115
hvnhpro
H
nobita994
Trừ số lượng dần theo dòng khi quét Sumif tổng có tên sản phẩm bị trùng.
Trả lời
2
Đọc
86
bebo021999
B
PhanTuHuong
Bàn về môn thể thao bóng bàn nào!
    • Thích
    • Yêu thích
    • Cười
2
Trả lời
37
Đọc
2K
cantl
C
Xem thêm…

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

Back
Top Bottom