Lọc lấy dữ liệu trùng bằng VBA

Liên hệ QC
vanhesing

vanhesing

Thành viên thường trực
Tham gia
12/8/10
Bài viết
223
Được thích
30
Dear Anh Chị !
Tôi có 1 vấn đề cần được sự giúp đỡ của anh chị về code lọc lấy trùng . Dạo 1 vòng diễn đàn tôi thấy đa số toàn là lọc bỏ trùng chứ ít có bài lọc lấy trùng .
trong file của tôi , tôi cũng dùng code sưu tầm trên GPE (cái mà tôi có thể hiểu nhất trong đa số code lọc ) nhưng tôi sử dụng code đó vào mục đích lọc lấy trùng 1 cách rất thủ công .khó mà trình bày hết quan điểm nên mời các Anh chị xem code trong file chắc anh Chị sẽ hiểu được mục đích của tôi muốn gì .
Tốm tắt mục đích của tôi là
1.muốn lọc lấy những dữ liệu ở cột loại lỗi bị lặp lại từ 2 lần trở lên sau đó copy qua sheet khác.
2.Cho tôi 1 code đóng khung tham khảo , vì những code mà tui lượm lặt trên GPE chỉ đóng khung khi data có từ 2 dòng trở lên còn nếu 1 dòng thì nó copy cả cái tiêu đề xuống .
Thanks và chúc sức khỏe
 

File đính kèm

  • loclaytrung.xls
    66.5 KB · Đọc: 609
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn tạm xài macro sau & bổ sung những thứ cần thiết với bạn

PHP: 
Option Explicit
Private Sub CommandButton1_Click()
 Dim Cls As Range, Rng As Range, sRng As Range
 Dim jJ As Long
 Dim MyAdd As String
 
 [AB6].CurrentRegion.Offset(1).Clear
 Set Rng = Range([f5], [f6].End(xlDown))
 For Each Cls In Range([X6], [X6].End(xlDown))
    Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            jJ = jJ + 1
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
        If jJ > 1 Then
            Cells(sRng.Row, "A").Resize(, 26).Copy Destination:=[AA65500].End(xlUp).Offset(1)
        End If
        jJ = 0
    End If
 Next Cls
 Randomize
 [f5].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End Sub
 
Upvote 0
vanhesing đã viết:
1.muốn lọc lấy những dữ liệu ở cột loại lỗi bị lặp lại từ 2 lần trở lên sau đó copy qua sheet khác.
Nhấp chuột vào đây để mở rộng...

Tôi nghĩ cái này có thể dùng Advanced Filter để lọc được mà.
Công thức cho vùng điều kiện lọc là: =COUNTIF($F$6:$F$1000,F6)>1
 
Upvote 0
HYen17 đã viết:
PHP: 
Option Explicit
Private Sub CommandButton1_Click()
 Dim Cls As Range, Rng As Range, sRng As Range
 Dim jJ As Long
 Dim MyAdd As String
 
 [AB6].CurrentRegion.Offset(1).Clear
 Set Rng = Range([f5], [f6].End(xlDown))
 For Each Cls In Range([X6], [X6].End(xlDown))
    Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            jJ = jJ + 1
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
        If jJ > 1 Then
            Cells(sRng.Row, "A").Resize(, 26).Copy Destination:=[AA65500].End(xlUp).Offset(1)
        End If
        jJ = 0
    End If
 Next Cls
 Randomize
 [f5].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End Sub
Nhấp chuột vào đây để mở rộng...

Dear HYen!
Bạn vẫn chưa hiểu ý mình . ý của mình là khi có 1 loại lỗi nào đó xuất hiện trên 2 lần trong 1 vùng data thì sẽ copy tất cả số lần đó qua AA6 . Vì mỗi 1 dòng là 1 thông tin của 1 máy nếu lọc những lỗi lặp lại trên 2 lần rồi lại bỏ trùng những dòng khác thì xem như thông tin bị sai .Thú thật code đơn giản thì mình có thể hiểu chứ nhìn mấy cái for earch này cũng đã nghiên cứu kĩ lắm nhưng nó đa dạng theo mỗi bài quá mình vẫn ko nắm được công dụng của nó .hic
Thanks
 
Upvote 0
ndu96081631 đã viết:
Tôi nghĩ cái này có thể dùng Advanced Filter để lọc được mà.
Công thức cho vùng điều kiện lọc là: =COUNTIF($F$6:$F$1000,F6)>1
Nhấp chuột vào đây để mở rộng...
Dear Bác NDU!
vùng data của e rất lớn nếu dùn công thức thì file sẽ nặng , e đang hạn chế công thức trong file tận dụng tối đa code để giành dung lượng cho data nhập liệu .
Thanks Bác
 
Upvote 0
vanhesing đã viết:
Dear Bác NDU!
vùng data của e rất lớn nếu dùn công thức thì file sẽ nặng , e đang hạn chế công thức trong file tận dụng tối đa code để giành dung lượng cho data nhập liệu .
Thanks Bác
Nhấp chuột vào đây để mở rộng...
Hình như bạn chưa hiểu tôi nói gì thì phải
Công thức chỉ gõ trong 1 CELL làm điều kiện cho Advanced Filter thôi mà (có phải gõ nguyên bảng tính đâu)
Code viết dựa theo ý tưởng trên
Mã: 
Sub LocTrung()
  With Sheet1
    .Range("IV2") = "=COUNTIF($F$6:$F$1000,F6)>1 "
    .Range("A5:V1000").AdvancedFilter 2, .Range("IV1:IV2"), Sheet2.Range("A6:V6")
    .Range("IV1:IV2").Clear
  End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
vanhesing đã viết:
Dear Bác NDU!
vùng data của e rất lớn nếu dùn công thức thì file sẽ nặng , e đang hạn chế công thức trong file tận dụng tối đa code để giành dung lượng cho data nhập liệu .
Thanks Bác
Nhấp chuột vào đây để mở rộng...

Mình có thắc mắc thế này ! tại sao các loại lỗi không được mã hoá thành các số hiệu lỗi như ERR1,ERR2... ,
Các loại lỗi và được diễn giải theo kiểu unicode có vẻ không ổn cho lắm,

+ Dùng advanced Filter như anh Ndu đã hướng dẫn bạn có 2 ưu điểm rất lớn :
** Đơn giản, ngắn gọn ,dễ hiểu
** Tốc độ rất nhanh ( mình có cảm giác nhanh hơn bất kỳ hàm hay thủ tục tự tạo nào )
* Nhược điểm : Nếu vùng dữ liệu lớn hơn 10000 dòng , thì phải dùng phương án khác !!
 
Upvote 0
vanhesing đã viết:
Dear Bác NDU!
vùng data của e rất lớn nếu dùn công thức thì file sẽ nặng , e đang hạn chế công thức trong file tận dụng tối đa code để giành dung lượng cho data nhập liệu .
Thanks Bác
Nhấp chuột vào đây để mở rộng...
Nếu bạn không chịu kiểu "Advanced Filter" thì khuyến mãi bạn Sub này xài thử, có Sort theo từng loại lỗi và ngày tháng luôn
PHP: 
Public Sub LOC_GPE()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range(.[F6], .[F65000].End(xlUp)).Offset(, -5).Resize(, 22).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 6)
    If Not Dic.Exists(Tem) Then
        Dic.Add Tem, 1
    Else
        Dic.Item(Tem) = Dic.Item(Tem) + 1
    End If
Next I
For I = 1 To UBound(sArr, 1)
    If sArr(I, 6) <> vbNullString Then Tem = sArr(I, 6)
    If Dic.Item(Tem) >= 2 Then
        K = K + 1
        For J = 1 To 22
            dArr(K, J) = sArr(I, J)
        Next J
    End If
Next I
With Sheet2
    .[A6:A65000].ClearContents
    .[A6:A65000].Borders.LineStyle = xlNone
    .[A6].Resize(K, UBound(sArr, 2)).Value = dArr
    .[A6].Resize(K, UBound(sArr, 2)).Borders.LineStyle = xlContinuous
    .[A6].Resize(K, UBound(sArr, 2)).Sort Key1:=.[F6], Key2:=.[G6]
End With
Set Dic = Nothing
End Sub
 
Upvote 0
ndu96081631 đã viết:
Hình như bạn chưa hiểu tôi nói gì thì phải
Công thức chỉ gõ trong 1 CELL làm điều kiện cho Advanced Filter thôi mà (có phải gõ nguyên bảng tính đâu)
Code viết dựa theo ý tưởng trên
Mã: 
Sub LocTrung()
  With Sheet1
    .Range("IV2") = "=COUNTIF($F$6:$F$1000,F6)>1 "
    .Range("A5:V1000").AdvancedFilter 2, .Range("IV1:IV2"), Sheet2.Range("A6:V6")
    .Range("IV1:IV2").Clear
  End With
End Sub
Nhấp chuột vào đây để mở rộng...

Ngày e càng phục Bác hơn rồi đấy . code Bác nhìn đơn giản và ngắn gọn quá .
Bây giờ e muốn lọc thêm 1 cột nữa đó là cột mã ATM , theo thứ tự lọc là cột Mã ATM trước rồi mới lọc lỗi sau .Trong bài Bác tùy chỉnh giúp em mã ATM giống nhau của những lỗi lặp lại . mục đích là muốn lọc ra ATM nào bị lỗi lặp lại nhiều lần .(chổ này do lúc post bài có sơ suất mong Bác thông cảm )
Thanks
 
Lần chỉnh sửa cuối:
Upvote 0
Ba Tê đã viết:
Nếu bạn không chịu kiểu "Advanced Filter" thì khuyến mãi bạn Sub này xài thử, có Sort theo từng loại lỗi và ngày tháng luôn
Nhấp chuột vào đây để mở rộng...

Anh hổng thấy ở trên "hắn" nói vầy sao:
vanhesing đã viết:
Thú thật code đơn giản thì mình có thể hiểu chứ nhìn mấy cái for earch này cũng đã nghiên cứu kĩ lắm nhưng nó đa dạng theo mỗi bài quá mình vẫn ko nắm được công dụng của nó .hic
Thanks
Nhấp chuột vào đây để mở rộng...
Như cái của anh thì đến bao giờ "hắn" mới hiểu đây?
Ẹc... Ẹc...
------------------------
vanhesing đã viết:
Ngày e càng phục Bác hơn rồi đấy . code Bác nhìn đơn giản và ngắn gọn quá .
Bây giờ e muốn lọc thêm 1 cột nữa đó là cột mã ATM , theo thứ tự lọc là cột Mã ATM trước rồi mới lọc lỗi sau . mục đích là muốn lọc ra ATM nào bị lỗi lặp lại nhiều lần .(chổ này do lúc post bài có sơ suất mong Bác thông cảm )
Thanks
Nhấp chuột vào đây để mở rộng...
Bạn cứ lọc bằng tay, dùng Advanced Filter đi.
Làm được bằng tay, ta chuyển sang code mấy hồi (ít nhất là record macro)
 
Upvote 0
hungpecc1 đã viết:
Mình có thắc mắc thế này ! tại sao các loại lỗi không được mã hoá thành các số hiệu lỗi như ERR1,ERR2... ,
Các loại lỗi và được diễn giải theo kiểu unicode có vẻ không ổn cho lắm,

+ Dùng advanced Filter như anh Ndu đã hướng dẫn bạn có 2 ưu điểm rất lớn :
** Đơn giản, ngắn gọn ,dễ hiểu
** Tốc độ rất nhanh ( mình có cảm giác nhanh hơn bất kỳ hàm hay thủ tục tự tạo nào )
* Nhược điểm : Nếu vùng dữ liệu lớn hơn 10000 dòng , thì phải dùng phương án khác !!
Nhấp chuột vào đây để mở rộng...

Bạn nói cũng đúng , thật ra vùng data được mình tổng hợp từ những nhân viên phụ trách khu vực vùng . những loại lỗi cũng tùy vào list vadation mỗi người . ở đây những lỗi unicode được thống nhất và phổ biến cho những nhân viên này . Tuy nhiên , mình cám ơn bạn đã chia sẽ thắc mắc . Để khắc phục nhược điểm mình chỉ cần tạo 1 cột phụ vlookup mã lỗi là được .
Thanks
 
Upvote 0
ndu96081631 đã viết:
Anh hổng thấy ở trên "hắn" nói vầy sao:

Như cái của anh thì đến bao giờ "hắn" mới hiểu đây?
Ẹc... Ẹc...
------------------------

Bạn cứ lọc bằng tay, dùng Advanced Filter đi.
Làm được bằng tay, ta chuyển sang code mấy hồi (ít nhất là record macro)
Nhấp chuột vào đây để mở rộng...

Thanks Bác . em đã làm được .
 
Upvote 0
Ba Tê đã viết:
Nếu bạn không chịu kiểu "Advanced Filter" thì khuyến mãi bạn Sub này xài thử, có Sort theo từng loại lỗi và ngày tháng luôn
PHP: 
Public Sub LOC_GPE()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range(.[F6], .[F65000].End(xlUp)).Offset(, -5).Resize(, 22).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 6)
    If Not Dic.Exists(Tem) Then
        Dic.Add Tem, 1
    Else
        Dic.Item(Tem) = Dic.Item(Tem) + 1
    End If
Next I
For I = 1 To UBound(sArr, 1)
    If sArr(I, 6) <> vbNullString Then Tem = sArr(I, 6)
    If Dic.Item(Tem) >= 2 Then
        K = K + 1
        For J = 1 To 22
            dArr(K, J) = sArr(I, J)
        Next J
    End If
Next I
With Sheet2
    .[A6:A65000].ClearContents
    .[A6:A65000].Borders.LineStyle = xlNone
    .[A6].Resize(K, UBound(sArr, 2)).Value = dArr
    .[A6].Resize(K, UBound(sArr, 2)).Borders.LineStyle = xlContinuous
    .[A6].Resize(K, UBound(sArr, 2)).Sort Key1:=.[F6], Key2:=.[G6]
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...


Cảm ơn anh Ba Tê. em sẽ nghiên cứu và học hỏi Sub a khuyến mãi cho
 
Upvote 0
Ba Tê đã viết:
Nếu bạn không chịu kiểu "Advanced Filter" thì khuyến mãi bạn Sub này xài thử, có Sort theo từng loại lỗi và ngày tháng luôn
PHP: 
Public Sub LOC_GPE()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range(.[F6], .[F65000].End(xlUp)).Offset(, -5).Resize(, 22).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 6)
    If Not Dic.Exists(Tem) Then
        Dic.Add Tem, 1
    Else
        Dic.Item(Tem) = Dic.Item(Tem) + 1
    End If
Next I
For I = 1 To UBound(sArr, 1)
    If sArr(I, 6) <> vbNullString Then Tem = sArr(I, 6)
    If Dic.Item(Tem) >= 2 Then
        K = K + 1
        For J = 1 To 22
            dArr(K, J) = sArr(I, J)
        Next J
    End If
Next I
With Sheet2
    .[A6:A65000].ClearContents
    .[A6:A65000].Borders.LineStyle = xlNone
    .[A6].Resize(K, UBound(sArr, 2)).Value = dArr
    .[A6].Resize(K, UBound(sArr, 2)).Borders.LineStyle = xlContinuous
    .[A6].Resize(K, UBound(sArr, 2)).Sort Key1:=.[F6], Key2:=.[G6]
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

.[A6].Resize(K, UBound(sArr, 2)).Sort Key1:=.[F6], Key2:=.[G6]
Câu lệnh này sắp xếp tăng dần, bây giờ muốn sắp xếp giảm dần thì mình ghi như thế nào anh bate. Từ trước tới giờ ghi macro sửa lại làm rất ok, nhưng thấy cái này ngắn gọn nên muốn học hỏi, cảm ơn anh nhiều
hiểu rồi
Sheet1.[A1].Resize(15, 4).Sort Key1:=Sheet1.[C1], Order1:=xlDescending
lúc trước ghi Order:=xlDescending hắn không ra
 
Lần chỉnh sửa cuối:
Upvote 0
Xin chào các anh chị. Em đang đi tìm 1 code lọc trùng mà chưa thấy. Em xin hỏi tiếp vào bài này ạ cho đỡ chiếm tài nguyên và người sau cũng tiện theo dõi ạ. Lấy file #1 làm ví dụ thì mong muốn của em như sau:
1/ Lọc lấy tất cả giá trị bị trùng lặp tại cột B sheet1 sang sheet2(tất tần tật)
Như theo file thì giá trị "CN Hà Nội" xuất hiện 4 lần, em muốn lấy tất cả 4 lần đó(giá trị bị trùng)
2/ Lọc lấy những giá trị còn lại sang sheet3(tất tần tật)
Tức là những giá trị đã lọc sang sheet2 thì sẽ không xuất hiện trong sheet3(giá trị không bị trùng)

Tóm lại em muốn lọc giá trị bị trùng sang 1 sheet để tiếp tục xử lý, và giá trị không bị trùng sang 1 sheet. Rất mong các ac hỗ trợ ạ. Chân trọng cảm ơn ạ!!!
 
Upvote 0
Mình đã thực hiện code macro như trong file.
Do code này là ý tưởng từ lượm nhặt trên diễn đàn.
Quá trình thực hiện mình thấy nó chạy ổn. Nhưng hơi chậm. Do dữ liệu mình cần làm khá lớn. (Trên 90000 dòng)
Bạn nào có code hay cho mình học hỏi thêm với nhé.
 

File đính kèm

  • THUCHANH.xlsm
    2.8 MB · Đọc: 122
Upvote 0
LinhlxTBS đã viết:
Mình đã thực hiện code macro như trong file.
Do code này là ý tưởng từ lượm nhặt trên diễn đàn.
Quá trình thực hiện mình thấy nó chạy ổn. Nhưng hơi chậm. Do dữ liệu mình cần làm khá lớn. (Trên 90000 dòng)
Bạn nào có code hay cho mình học hỏi thêm với nhé.
Nhấp chuột vào đây để mở rộng...
Cái code này có phải lọc trùng đâu nhỉ.Đây là tìm kiếm dữ liệu mà.
 
Upvote 0
Do code mình thực hiện sử dụng chức năng AutoFilter lọc theo điều kiện như mình đã trình bày trong file. Nên mình nghĩ đang sử dụng chức năng lộc để sao chép dử liệu.
Hôm trước Bạn có code gửi mình tham khảo thấy rất hay. Nay mong được Bạn chỉ giáo thêm. Cảm ơn!
 
Upvote 0
Ba Tê đã viết:
Nếu bạn không chịu kiểu "Advanced Filter" thì khuyến mãi bạn Sub này xài thử, có Sort theo từng loại lỗi và ngày tháng luôn
PHP: 
Public Sub LOC_GPE()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range(.[F6], .[F65000].End(xlUp)).Offset(, -5).Resize(, 22).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 6)
    If Not Dic.Exists(Tem) Then
        Dic.Add Tem, 1
    Else
        Dic.Item(Tem) = Dic.Item(Tem) + 1
    End If
Next I
For I = 1 To UBound(sArr, 1)
    If sArr(I, 6) <> vbNullString Then Tem = sArr(I, 6)
    If Dic.Item(Tem) >= 2 Then
        K = K + 1
        For J = 1 To 22
            dArr(K, J) = sArr(I, J)
        Next J
    End If
Next I
With Sheet2
    .[A6:A65000].ClearContents
    .[A6:A65000].Borders.LineStyle = xlNone
    .[A6].Resize(K, UBound(sArr, 2)).Value = dArr
    .[A6].Resize(K, UBound(sArr, 2)).Borders.LineStyle = xlContinuous
    .[A6].Resize(K, UBound(sArr, 2)).Sort Key1:=.[F6], Key2:=.[G6]
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Anh ơi , e dùng cái mã này nhưng nó cứ bị lỗi Run-time error'1004' . To do this, all the merged cells need to be same size. mà em ko dùng merge
 
Upvote 0
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

LuuAnh980
Sao Filter của Excel kỳ lạ.
Trả lời
1
Đọc
2
BuiQuangThuan
B
T
[Giúp đỡ] Tìm số lượng nhân viên đã tham gia làm lô hàng
Trả lời
3
Đọc
64
hoangtuaotrang_hp_vn
H
hoang.buivan93
Gặp rắc rối về phần công thức hàm tìm kiếm dữ liệu. Nhờ mọi người chỉ giáo giúp ạ.
Trả lời
1
Đọc
36
Hoàng Trọng Nghĩa
Hoàng Trọng Nghĩa
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
Trả lời
8
Đọc
949
thientac
T
A
[Cần Giúp] Excel nhiều người dùng cùng lúc
Trả lời
5
Đọc
121
hvnhpro
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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