Lọc dữ liệu trùng ra một sheet khác

hoahuongduong1986 · 22/12/20

Dear Anh chị và các bạn,
Em có một bảng các giao dịch nhập xuất hàng hóa. Giờ em muốn kiểm soát và lọc ra các giao dịch trùng nhau theo các trường màu vàng từ C đến J tại Sheet Data và lọc ra các giao dịch trùng nhau này sang Sheet Ket qua loc. Thì code gì thực hiện được ạ.

Maika8008 · 22/12/20

hoahuongduong1986 đã viết:
Dear Anh chị và các bạn,
Em có một bảng các giao dịch nhập xuất hàng hóa. Giờ em muốn kiểm soát và lọc ra các giao dịch trùng nhau theo các trường màu vàng từ C đến J tại Sheet Data và lọc ra các giao dịch trùng nhau này sang Sheet Ket qua loc. Thì code gì thực hiện được ạ.

Xem file của bạn, tôi không biết bạn nói giao dịch trùng nhau là trùng ở (những) cột nào? Theo mấy dòng tô màu của bạn tôi thấy với ông Trần Văn A thì mua hàng hay bán hàng bạn cũng tô màu hết?

hoahuongduong1986 · 22/12/20

Maika8008 đã viết:
Xem file của bạn, tôi không biết bạn nói giao dịch trùng nhau là trùng ở (những) cột nào? Theo mấy dòng tô màu của bạn tôi thấy với ông Trần Văn A thì mua hàng hay bán hàng bạn cũng tô màu hết?

Dạ,
- Các giao dịch trung nhau là các trường màu vàng từ C đến J đó ạ
- Em đưa ra hai ví dụ ông Nguyễn Văn A và Trần Văn C ạ. Nguyễn Văn A có 3 dòng nhưng có 2 dòng trung nhau toàn bộ từ C đến J ạ.

Nhattanktnn · 22/12/20

hoahuongduong1986 đã viết:
Dạ,
- Các giao dịch trung nhau là các trường màu vàng từ C đến J đó ạ
- Em đưa ra hai ví dụ ông Nguyễn Văn A và Trần Văn C ạ. Nguyễn Văn A có 3 dòng nhưng có 2 dòng trung nhau toàn bộ từ C đến J ạ.

bạn xem thử file :

Mã:

Option Explicit
Sub LocTrung()
Dim sArr(), dArr(), I&, J&, K&, N&, Txt$, R&, R1&, Dic As Object
With Sheets("Data")
    sArr = .Range("B9:J" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    R = UBound(sArr, 1): R1 = UBound(sArr, 2)
End With
ReDim dArr(1 To R, 1 To R1)
Set Dic = CreateObject("Scripting.Dictionary")
For I = 1 To R
    For J = 2 To R1
        Txt = Txt & "#" & UCase(Trim(sArr(I, J)))
    Next
    If Not Dic.exists(Txt) Then
        Dic.Add (Txt), Array(I, 0)
    Else
        N = N + 1
        Dic.Item(Txt) = Array(Dic.Item(Txt)(0), Dic.Item(Txt)(1) + 1)
        If Dic.Item(Txt)(1) = 1 Then
            For K = 1 To R1
                dArr(N, K) = sArr(Dic.Item(Txt)(0), K)
            Next
            N = N + 1
        End If
        For K = 1 To R1
            dArr(N, K) = sArr(I, K)
        Next
    End If
    Txt = ""
Next
With Sheets("Ket qua loc").Range("A2")
    .Resize(10000, R1).ClearContents
    .Resize(R, R1) = dArr
    .Resize(R, R1).Sort Range("B2"), Header:=xlNo
End With
End Sub

Cu Tồ · 22/12/20

hoahuongduong1986 đã viết:
Dạ,
- Các giao dịch trung nhau là các trường màu vàng từ C đến J đó ạ
- Em đưa ra hai ví dụ ông Nguyễn Văn A và Trần Văn C ạ. Nguyễn Văn A có 3 dòng nhưng có 2 dòng trung nhau toàn bộ từ C đến J ạ.

Mã:

Option Explicit

Sub Loc()
Dim Data(), KQ()
Dim I As Long, j As Long, K As Long, DK As String
Dim Dic As Object

Set Dic = CreateObject("Scripting.Dictionary")

With Sheet1
    Data = .Range("B9", .Range("B" & Rows.Count).End(xlUp)).Resize(, 9).Value
    ReDim KQ(1 To UBound(Data), 1 To 9)
    For I = 1 To UBound(Data)
        DK = Data(I, 2) & Data(I, 3) & Data(I, 4) & Data(I, 5) & Data(I, 6) & Data(I, 7) & Data(I, 8) & Data(I, 9)
            If Not Dic.Exists(DK) Then
                Dic.Add DK, 1
            Else
                Dic.Item(DK) = Dic.Item(DK) + 1
            End If
    Next
    For I = 1 To UBound(Data)
        DK = Data(I, 2) & Data(I, 3) & Data(I, 4) & Data(I, 5) & Data(I, 6) & Data(I, 7) & Data(I, 8) & Data(I, 9)
            If Dic.Item(DK) > 1 Then
                         K = K + 1
                    KQ(K, 1) = Data(I, 1)
                For j = 2 To 9
                    KQ(K, j) = Data(I, j)
                Next
            End If
    Next
End With
Set Dic = Nothing
Sheet2.Range("A2").Resize(K, 9) = KQ
Sheet2.Range("A1").Resize(K + 1, 9).Sort Key1:=Sheet1.Range("B1"), Order1:=xlTopToBottom, Header:=xlYes
End Sub

Góp vui code này

hoahuongduong1986 · 22/12/20

Nhattanktnn đã viết:

bạn xem thử file :

Mã:

Option Explicit
Sub LocTrung()
Dim sArr(), dArr(), I&, J&, K&, N&, Txt$, R&, R1&, Dic As Object
With Sheets("Data")
    sArr = .Range("B9:J" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    R = UBound(sArr, 1): R1 = UBound(sArr, 2)
End With
ReDim dArr(1 To R, 1 To R1)
Set Dic = CreateObject("Scripting.Dictionary")
For I = 1 To R
    For J = 2 To R1
        Txt = Txt & "#" & UCase(Trim(sArr(I, J)))
    Next
    If Not Dic.exists(Txt) Then
        Dic.Add (Txt), Array(I, 0)
    Else
        N = N + 1
        Dic.Item(Txt) = Array(Dic.Item(Txt)(0), Dic.Item(Txt)(1) + 1)
        If Dic.Item(Txt)(1) = 1 Then
            For K = 1 To R1
                dArr(N, K) = sArr(Dic.Item(Txt)(0), K)
            Next
            N = N + 1
        End If
        For K = 1 To R1
            dArr(N, K) = sArr(I, K)
        Next
    End If
    Txt = ""
Next
With Sheets("Ket qua loc").Range("A2")
    .Resize(10000, R1).ClearContents
    .Resize(R, R1) = dArr
    .Resize(R, R1).Sort Range("B2"), Header:=xlNo
End With
End Sub

Em cảm ơn anh nhiều ạ !

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

Cu Tồ đã viết:

Mã:

Option Explicit

Sub Loc()
Dim Data(), KQ()
Dim I As Long, j As Long, K As Long, DK As String
Dim Dic As Object

Set Dic = CreateObject("Scripting.Dictionary")

With Sheet1
    Data = .Range("B9", .Range("B" & Rows.Count).End(xlUp)).Resize(, 9).Value
    ReDim KQ(1 To UBound(Data), 1 To 9)
    For I = 1 To UBound(Data)
        DK = Data(I, 2) & Data(I, 3) & Data(I, 4) & Data(I, 5) & Data(I, 6) & Data(I, 7) & Data(I, 8) & Data(I, 9)
            If Not Dic.Exists(DK) Then
                Dic.Add DK, 1
            Else
                Dic.Item(DK) = Dic.Item(DK) + 1
            End If
    Next
    For I = 1 To UBound(Data)
        DK = Data(I, 2) & Data(I, 3) & Data(I, 4) & Data(I, 5) & Data(I, 6) & Data(I, 7) & Data(I, 8) & Data(I, 9)
            If Dic.Item(DK) > 1 Then
                         K = K + 1
                    KQ(K, 1) = Data(I, 1)
                For j = 2 To 9
                    KQ(K, j) = Data(I, j)
                Next
            End If
    Next
End With
Set Dic = Nothing
Sheet2.Range("A2").Resize(K, 9) = KQ
Sheet2.Range("A1").Resize(K + 1, 9).Sort Key1:=Sheet1.Range("B1"), Order1:=xlTopToBottom, Header:=xlYes
End Sub

Góp vui code này

Em cảm ơn anh nhiều ạ !

Lọc dữ liệu trùng ra một sheet khác

hoahuongduong1986

Thành viên thường trực

File đính kèm

Maika8008

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

hoahuongduong1986

Thành viên thường trực

Nhattanktnn

Thành viên gắn bó

File đính kèm

Cu Tồ

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

hoahuongduong1986

Thành viên thường trự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