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

Liên hệ QC

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: 616
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
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.

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
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

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
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
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
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
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
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

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
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
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
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

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
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

Anh hổng thấy ở trên "hắn" nói vầy sao:
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ư cái của anh thì đến bao giờ "hắn" mới hiểu đây?
Ẹc... Ẹc...
------------------------
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
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
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 !!

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
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)

Thanks Bác . em đã làm được .
 
Upvote 0
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


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
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

.[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: 128
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é.
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
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
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
Web KT

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

Back
Top Bottom