Giúp sửa code trích lọc dữ liệu trùng giữa 2 sheet (4 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
bigbabol89

bigbabol89

Thành viên thường trực
Tham gia
15/10/12
Bài viết
226
Được thích
34
Dear các anh (chị ),

Em có sưu tầm được 1 file trích lọc dữ liệu trùng giữa 2 sheet, tuy nhiên, em cần sửa chút ít để phục vụ công việc của em. Mong các anh giúp đỡ :
- Khi chạy macro thì dữ liệu trùng chỉ hiện ở cột E => Em muốn dữ liệu điều kiện để lọc trùng vẫn là cột E nhưng khi kết quả có hiện thêm các thông tin ( kết quả sẽ bao gồm cột : A,B,C,D,E,F,V,W,X )
- Em cần so sánh 2 cặp sheet là : Active FT & Resign FT và Act PT & Reg PT ==> Nếu em muốn như vậy thì em phải làm 2 cái module và chỉnh tên sheet, có cách nào chỉ cần 1 module ko ạ.
Em đính kèm 1 file dữ liệu và 1 file kq mong muốn.

Em cám ơn
 

File đính kèm

Cái này dùng code làm gì cho nó mệt ra, dùng công thức, hàm match kết hợp với lọc là được, chịu khó copy bằng tay là được, vô cùng nhanh mà không phụ thuộc code.
 
truongvu317 đã viết:
Cái này dùng code làm gì cho nó mệt ra, dùng công thức, hàm match kết hợp với lọc là được, chịu khó copy bằng tay là được, vô cùng nhanh mà không phụ thuộc code.
Nhấp chuột vào đây để mở rộng...
Làm tay cái này thì em cũng biết làm mà, nhưng mà em thấy vba nhanh, tiện dụng...nên hào hứng hơn
 

File đính kèm

Lần chỉnh sửa cuối:
♫ђöล♥ßล†♥†µ♫ đã viết:
Bạn thử Code này xem
PHP: 
Sub Compare()
    Dim Ws As Worksheet, Arr, Col, N As Long, Pth, Rng As Range
    Dim Dic As Object, Tem As String
    Dim sArr(), dArr(), I As Long, J As Long, K As Long
Arr = Array("Active FT", "Resign FT", "Act PT", "Reg PT")
Col = Array(2, 3, 4, 5, 6, 22, 23, 24)
Pth = ActiveWorkbook.Path
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets(Arr(0)).Cells(1, 1)
For J = LBound(Col) To UBound(Col)
    Set Rng = Union(Rng, Sheets(Arr(0)).Cells(1, Col(J)))
Next J
ReDim dArr(1 To 65535, 1 To UBound(Col) + 2)
For N = LBound(Arr) To UBound(Arr)
    With Sheets(Arr(N))
        sArr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 24).Value
        For I = 1 To UBound(sArr)
            Tem = sArr(I, 5)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add Tem, ""
                dArr(K, 1) = K
                For J = LBound(Col) To UBound(Col)
                    dArr(K, J + 2) = sArr(I, Col(J))
                Next J
            End If
        Next I
    End With
Next N
Application.Workbooks.Add
Set Ws = Application.ActiveSheet
Rng.Copy
Ws.Range("A1").PasteSpecial xlPasteColumnWidths
Ws.Range("A1").PasteSpecial xlPasteValues
Ws.Range("A1").PasteSpecial xlPasteFormats
Ws.Range("A2").Resize(K, UBound(dArr, 2)) = dArr
Ws.Range("A1").Resize(K + 1, UBound(dArr, 2)).Borders.LineStyle = 1
ActiveWorkbook.Close True, Pth & "\" & "KQ." & Format(Now(), "dd.mmm.yyyy") & ".xlsx"
Set Dic = Nothing
MsgBox "Xong!"
End Sub
Nhấp chuột vào đây để mở rộng...
Anh xem lại giúp em với :
- Em chỉ cần lọc ra dữ liệu bị trùng giữa 2 cặp sheet : Active FT vs Resign FT và Act PT vs Reg PT. ( ý là so sánh sheet active ft và resign ft xem có giá trị trùng nào thì lọc ra, đk trùng là cột E ), tương tự với cặp sheet kia —> em chạy thấy kết quả ko ra giá trị trùng mà ra tất cả luôn.
- Nếu có thể thì 1 lần chạy code so sánh 2 cặp sheet trên thành 2 bảng riêng, phân tách bằng 1 hàng trống cũng đc ah.
- Anh cho em trích dữ liệu ra 1 workbook mới như kiểu tạm thời ( book1, book2,...) đc ko ạ. Ko cần đặt tên đâu ạ
 
bigbabol89 đã viết:
Anh xem lại giúp em với :
- Em chỉ cần lọc ra dữ liệu bị trùng giữa 2 cặp sheet : Active FT vs Resign FT và Act PT vs Reg PT. ( ý là so sánh sheet active ft và resign ft xem có giá trị trùng nào thì lọc ra, đk trùng là cột E ), tương tự với cặp sheet kia —> em chạy thấy kết quả ko ra giá trị trùng mà ra tất cả luôn.
- Nếu có thể thì 1 lần chạy code so sánh 2 cặp sheet trên thành 2 bảng riêng, phân tách bằng 1 hàng trống cũng đc ah.
- Anh cho em trích dữ liệu ra 1 workbook mới như kiểu tạm thời ( book1, book2,...) đc ko ạ. Ko cần đặt tên đâu ạ
Nhấp chuột vào đây để mở rộng...
Bạn thử lại với cái Code này nha
PHP: 
Sub Compare()
    Dim Ws As Worksheet, Arr, Col, N As Long, Pth, Rng As Range
    Dim Dic As Object, Tem As String
    Dim sArr(), dArr(), I As Long, J As Long, K As Long, Stt As Long, Ir As Long
Arr = Array("Active FT", "Resign FT", "Act PT", "Reg PT")
Col = Array(2, 3, 4, 5, 6, 22, 23, 24)
Pth = ActiveWorkbook.Path
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets(Arr(0)).Cells(1, 1)
For J = LBound(Col) To UBound(Col)
    Set Rng = Union(Rng, Sheets(Arr(0)).Cells(1, Col(J)))
Next J
ReDim dArr(1 To 65535, 1 To UBound(Col) + 2)
For N = LBound(Arr) To UBound(Arr)
    If N = 2 Then
        Dic.RemoveAll: K = K + 1: Ir = K + 1: Stt = 0
    End If
    With Sheets(Arr(N))
        sArr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 24).Value
        For I = 1 To UBound(sArr)
            Tem = sArr(I, 5)
            If Not Dic.Exists(Tem) Then
                Dic.Add Tem, ""
            Else
                K = K + 1: Stt = Stt + 1: dArr(K, 1) = Stt
                For J = LBound(Col) To UBound(Col)
                    dArr(K, J + 2) = sArr(I, Col(J))
                Next J
            End If
        Next I
    End With
Next N
If K Then
    Application.Workbooks.Add
    Set Ws = Application.ActiveSheet
    Rng.Copy
    With Ws
        .Range("A1").PasteSpecial xlPasteColumnWidths
        .Range("A1").PasteSpecial xlPasteValues
        .Range("A1").PasteSpecial xlPasteFormats
        .Range("A2").Resize(K, UBound(dArr, 2)) = dArr
        .Range("A1").Resize(K + 1, UBound(dArr, 2)).Borders.LineStyle = 1
        With Range("A" & Ir).Resize(, UBound(dArr, 2))
            .Interior.Color = 5287936
            .Borders(xlInsideVertical).LineStyle = xlNone
        End With
    End With
    Set Dic = Nothing
    MsgBox "Xong!"
Else
    MsgBox "Nothing"
End If
End Sub
 
Lần chỉnh sửa cuối:
bigbabol89 đã viết:
Anh xem lại giúp em với :
- Em chỉ cần lọc ra dữ liệu bị trùng giữa 2 cặp sheet : Active FT vs Resign FT và Act PT vs Reg PT. ( ý là so sánh sheet active ft và resign ft xem có giá trị trùng nào thì lọc ra, đk trùng là cột E ), tương tự với cặp sheet kia —> em chạy thấy kết quả ko ra giá trị trùng mà ra tất cả luôn.
- Nếu có thể thì 1 lần chạy code so sánh 2 cặp sheet trên thành 2 bảng riêng, phân tách bằng 1 hàng trống cũng đc ah.
- Anh cho em trích dữ liệu ra 1 workbook mới như kiểu tạm thời ( book1, book2,...) đc ko ạ. Ko cần đặt tên đâu ạ
Nhấp chuột vào đây để mở rộng...
Tạo 1 sheet mới tên GPE rồi chạy thử Sub này:
PHP: 
Public Sub s_Gpe()
Dim Dic As Object, I As Long, J As Long, K As Long, K2 As Long
Dim sArr(), ArrFT(1 To 100, 1 To 10), ArrPT(1 To 100, 1 To 10)
Set Dic = CreateObject("Scripting.Dictionary")
'----------------------------------------------
sArr = Sheets("Active FT").Range("A2", Sheets("Active FT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        Dic.Item(sArr(I, 5)) = ""
    Next I
'----------------------------------------------
sArr = Sheets("Resign FT").Range("A2", Sheets("Resign FT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        If Dic.Exists(sArr(I, 5)) Then
            K = K + 1
            ArrFT(K, 1) = K
            ArrFT(K, 2) = sArr(I, 2)
            For J = 3 To 6
                ArrFT(K, J) = sArr(I, J)
                ArrFT(K, J + 4) = sArr(I, J + 18)
            Next J
        End If
    Next I
'---------------------------------------------
Dic.RemoveAll
sArr = Sheets("Act PT").Range("A2", Sheets("Act PT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        Dic.Item(sArr(I, 5)) = ""
    Next I
'----------------------------------------------
sArr = Sheets("Reg PT").Range("A2", Sheets("Reg PT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        If Dic.Exists(sArr(I, 5)) Then
            K2 = K2 + 1
            ArrPT(K2, 1) = K2
            ArrPT(K2, 2) = sArr(I, 2)
            For J = 3 To 6
                ArrPT(K2, J) = sArr(I, J)
                ArrPT(K2, J + 4) = sArr(I, J + 18)
            Next J
        End If
    Next I
'---------------------------------------------------
With Sheets("GPE")
    .Range("A2").Resize(1000, 10).ClearContents
    .Range("A2").Resize(K, 10) = ArrFT
    .Range("A2").Offset(K + 2).Resize(K2, 10) = ArrPT
End With
End Sub
 
Ba Tê đã viết:
Tạo 1 sheet mới tên GPE rồi chạy thử Sub này:
PHP: 
Public Sub s_Gpe()
Dim Dic As Object, I As Long, J As Long, K As Long, K2 As Long
Dim sArr(), ArrFT(1 To 100, 1 To 10), ArrPT(1 To 100, 1 To 10)
Set Dic = CreateObject("Scripting.Dictionary")
'----------------------------------------------
sArr = Sheets("Active FT").Range("A2", Sheets("Active FT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        Dic.Item(sArr(I, 5)) = ""
    Next I
'----------------------------------------------
sArr = Sheets("Resign FT").Range("A2", Sheets("Resign FT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        If Dic.Exists(sArr(I, 5)) Then
            K = K + 1
            ArrFT(K, 1) = K
            ArrFT(K, 2) = sArr(I, 2)
            For J = 3 To 6
                ArrFT(K, J) = sArr(I, J)
                ArrFT(K, J + 4) = sArr(I, J + 18)
            Next J
        End If
    Next I
'---------------------------------------------
Dic.RemoveAll
sArr = Sheets("Act PT").Range("A2", Sheets("Act PT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        Dic.Item(sArr(I, 5)) = ""
    Next I
'----------------------------------------------
sArr = Sheets("Reg PT").Range("A2", Sheets("Reg PT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        If Dic.Exists(sArr(I, 5)) Then
            K2 = K2 + 1
            ArrPT(K2, 1) = K2
            ArrPT(K2, 2) = sArr(I, 2)
            For J = 3 To 6
                ArrPT(K2, J) = sArr(I, J)
                ArrPT(K2, J + 4) = sArr(I, J + 18)
            Next J
        End If
    Next I
'---------------------------------------------------
With Sheets("GPE")
    .Range("A2").Resize(1000, 10).ClearContents
    .Range("A2").Resize(K, 10) = ArrFT
    .Range("A2").Offset(K + 2).Resize(K2, 10) = ArrPT
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Chịu cha nội này thật, viết ra một cái sub con gồm hai tham số, rồi gọi cái sub con đó từ sub chính, vừa viết ngắn mà lại cơ đông, thích bao nhiêu cặp sheet cũng được.
 
Ba Tê đã viết:
Tạo 1 sheet mới tên GPE rồi chạy thử Sub này:
PHP: 
Public Sub s_Gpe()
Dim Dic As Object, I As Long, J As Long, K As Long, K2 As Long
Dim sArr(), ArrFT(1 To 100, 1 To 10), ArrPT(1 To 100, 1 To 10)
Set Dic = CreateObject("Scripting.Dictionary")
'----------------------------------------------
sArr = Sheets("Active FT").Range("A2", Sheets("Active FT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        Dic.Item(sArr(I, 5)) = ""
    Next I
'----------------------------------------------
sArr = Sheets("Resign FT").Range("A2", Sheets("Resign FT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        If Dic.Exists(sArr(I, 5)) Then
            K = K + 1
            ArrFT(K, 1) = K
            ArrFT(K, 2) = sArr(I, 2)
            For J = 3 To 6
                ArrFT(K, J) = sArr(I, J)
                ArrFT(K, J + 4) = sArr(I, J + 18)
            Next J
        End If
    Next I
'---------------------------------------------
Dic.RemoveAll
sArr = Sheets("Act PT").Range("A2", Sheets("Act PT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        Dic.Item(sArr(I, 5)) = ""
    Next I
'----------------------------------------------
sArr = Sheets("Reg PT").Range("A2", Sheets("Reg PT").Range("A2").End(xlDown)).Resize(, 24).Value
    For I = 1 To UBound(sArr)
        If Dic.Exists(sArr(I, 5)) Then
            K2 = K2 + 1
            ArrPT(K2, 1) = K2
            ArrPT(K2, 2) = sArr(I, 2)
            For J = 3 To 6
                ArrPT(K2, J) = sArr(I, J)
                ArrPT(K2, J + 4) = sArr(I, J + 18)
            Next J
        End If
    Next I
'---------------------------------------------------
With Sheets("GPE")
    .Range("A2").Resize(1000, 10).ClearContents
    .Range("A2").Resize(K, 10) = ArrFT
    .Range("A2").Offset(K + 2).Resize(K2, 10) = ArrPT
End With
End Sub
Nhấp chuột vào đây để mở rộng...
A ơi anh, do file em dùng là file ko đc phép thêm sheet ( do yêu cầu công việc ). Em dùng code để kiểm tra nên anh cho em kết quả ở workbook mới đc ko ạ ( book1, book2...).
♫ђöล♥ßล†♥†µ♫ đã viết:
Bạn thử lại với cái Code này nha
PHP: 
Sub Compare()
    Dim Ws As Worksheet, Arr, Col, N As Long, Pth, Rng As Range
    Dim Dic As Object, Tem As String
    Dim sArr(), dArr(), I As Long, J As Long, K As Long, Stt As Long, Ir As Long
Arr = Array("Active FT", "Resign FT", "Act PT", "Reg PT")
Col = Array(2, 3, 4, 5, 6, 22, 23, 24)
Pth = ActiveWorkbook.Path
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets(Arr(0)).Cells(1, 1)
For J = LBound(Col) To UBound(Col)
    Set Rng = Union(Rng, Sheets(Arr(0)).Cells(1, Col(J)))
Next J
ReDim dArr(1 To 65535, 1 To UBound(Col) + 2)
For N = LBound(Arr) To UBound(Arr)
    If N = 2 Then
        K = K + 1: Ir = K + 1: Stt = 0
    End If
    With Sheets(Arr(N))
        sArr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 24).Value
        For I = 1 To UBound(sArr)
            Tem = sArr(I, 5)
            If Not Dic.Exists(Tem) Then
                Dic.Add Tem, ""
            Else
                K = K + 1: Stt = Stt + 1
                dArr(K, 1) = Stt
                For J = LBound(Col) To UBound(Col)
                    dArr(K, J + 2) = sArr(I, Col(J))
                Next J
            End If
        Next I
    End With
Next N
If K Then
    Application.Workbooks.Add
    Set Ws = Application.ActiveSheet
    Rng.Copy
    With Ws
        .Range("A1").PasteSpecial xlPasteColumnWidths
        .Range("A1").PasteSpecial xlPasteValues
        .Range("A1").PasteSpecial xlPasteFormats
        .Range("A2").Resize(K, UBound(dArr, 2)) = dArr
        .Range("A1").Resize(K + 1, UBound(dArr, 2)).Borders.LineStyle = 1
        With Range("A" & Ir).Resize(, UBound(dArr, 2))
            .Interior.Color = 5287936
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
    End With
    Set Dic = Nothing
    MsgBox "Xong!"
Else
    MsgBox "Nothing"
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Do muộn rồi nên em onl bằng điện thoại nên cũng chưa thử đc. Nhưng em cũng rất cám ơn mn đã giúp đỡ.
 
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

D
Nhờ trợ giúp xác định thứ tự của các từ và cụm từ trong 1 chuỗi văn bản. (3 người xem)
Trả lời
5
Đọc
53
huhumalu
H
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu (1 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
14
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ (1 người xem)
Trả lời
17
Đọc
472
VetMini
V
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM (7 người xem)
Trả lời
0
Đọc
69
GPE-Trợ Lý
GPE-Trợ Lý
G
Xin Code xóa Module. (2 người xem)
Trả lời
10
Đọc
367
GCQ
G
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
348
Đọc
31K
ongke0711
ongke0711
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ (1 người xem)
2
Trả lời
23
Đọc
641
nguyendang95
N
G
Tách công thức ra khỏi chuỗi và tính kết quả?
2
Trả lời
26
Đọc
2K
thuytrangbp28
T
thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025 (1 người xem)
Trả lời
8
Đọc
156
bebo021999
B
N
Hàm tăng số đếm theo điều kiện
Trả lời
4
Đọc
78
bebo021999
B
M
Xin giúp đỡ làm công thức điều kiện
    • Yêu thích
Trả lời
3
Đọc
163
tayGa
T
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính (1 người xem)
    • Thích
Trả lời
2
Đọc
231
nguyendang95
N
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
5
Đọc
188
DeTong
D
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện. (1 người xem)
Trả lời
17
Đọc
291
tle2003
T
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
5
Đọc
124
VetMini
V
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
10
Đọc
5K
tle2003
T
C
  • Question Question
Xin hỏi Cách viết chú thích trong vba hiển thị tiếng việt
Trả lời
4
Đọc
198
ongke0711
ongke0711
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
28
Đọc
7K
Hoàng Tuấn 868
H
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
3
Đọc
180
tle2003
T
S
Mở 2 cửa sổ riêng biệt (1 người xem)
2
Trả lời
30
Đọc
23K
sakuraluu
S
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom