Lọc trùng giữa hai bảng bằng code VBA

Liên hệ QC
T

thao nguyen01

Thành viên thường trực
Tham gia
8/12/19
Bài viết
241
Được thích
30
Kính gửi anh/chị trên diễn đàn,

Em muốn lọc dữ liệu trùng nhau giữa 2 bảng bằng code VBA ạ (trùng tên và số hợp đồng ạ). Nếu không có dữ liệu trùng, sẽ hiện thông báo "Không có dữ liệu trùng nhau" ạ. Anh chị xem giúp em ạ. Em cảm ơn nhiều ạ.
 

File đính kèm

  • loc.xlsb
    8.6 KB · Đọc: 26
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Code làm gì cho mệt người hả bạn!
 

File đính kèm

  • loc.xlsb
    8.9 KB · Đọc: 17
Upvote 0
Cách đơn giản, dễ hiểu và trực quan nhất:
PHP: 
Sub loc()
Dim i, j, App
Set App = Application.WorksheetFunction
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 2 To Range("A65536").End(xlUp).Row
    If App.CountIfs(Range("D:D"), Cells(i, 1).Value, Range("E:E"), Cells(i, 2).Value) = 1 Then
        j = j + 1
        Cells(j + 1, 7).Value = Cells(i, 1).Value
        Cells(j + 1, 8).Value = Cells(i, 2).Value
    End If
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
vu_tuan_manh_linh đã viết:
Cách đơn giản, dễ hiểu và trực quan nhất:
PHP: 
Sub loc()
Dim i, j, App
Set App = Application.WorksheetFunction
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 2 To Range("A65536").End(xlUp).Row
    If App.CountIfs(Range("D:D"), Cells(i, 1).Value, Range("E:E"), Cells(i, 2).Value) = 1 Then
        j = j + 1
        Cells(j + 1, 7).Value = Cells(i, 1).Value
        Cells(j + 1, 8).Value = Cells(i, 2).Value
    End If
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Nhấp chuột vào đây để mở rộng...
Trường hợp dữ liệu "quá lớn" thì sẽ code khác mới chạy nhanh được.
 
Upvote 0
thao nguyen01 đã viết:
Kính gửi anh/chị trên diễn đàn,

Em muốn lọc dữ liệu trùng nhau giữa 2 bảng bằng code VBA ạ (trùng tên và số hợp đồng ạ). Nếu không có dữ liệu trùng, sẽ hiện thông báo "Không có dữ liệu trùng nhau" ạ. Anh chị xem giúp em ạ. Em cảm ơn nhiều ạ.
Nhấp chuột vào đây để mở rộng...
Khi nào cần nhanh thì xài code này
Mã: 
Sub Loc_Trung()
Dim Dic As Object, sArr_1(), sArr_2()
Dim Res(), k As Long, i As Long, ii As Long, tmp As String
Set Dic = CreateObject("scripting.dictionary")
sArr_1 = Range("A2", [A65536].End(3)).Resize(, 2).Value
sArr_2 = Range("D2", [D65536].End(3)).Resize(, 2).Value
ReDim Res(1 To UBound(sArr_2), 1 To 2)
For i = 1 To UBound(sArr_1)
   tmp = CStr(sArr_1(i, 2))
   Dic(tmp) = Empty
Next
For ii = 1 To UBound(sArr_2)
   tmp = CStr(sArr_2(ii, 2))
   If Dic.exists(tmp) Then
      k = k + 1
      Res(k, 1) = sArr_2(ii, 1)
      Res(k, 2) = sArr_2(ii, 2)
   End If
Next
[G2:H10000].ClearContents
If k Then [G2].Resize(k, 2) = Res Else MsgBox "No Data Found", vbInformation
End Sub
 
Upvote 0
quanghai1969 đã viết:
Khi nào cần nhanh thì xài code này
Mã: 
Sub Loc_Trung()
Dim Dic As Object, sArr_1(), sArr_2()
Dim Res(), k As Long, i As Long, ii As Long, tmp As String
Set Dic = CreateObject("scripting.dictionary")
sArr_1 = Range("A2", [A65536].End(3)).Resize(, 2).Value
sArr_2 = Range("D2", [D65536].End(3)).Resize(, 2).Value
ReDim Res(1 To UBound(sArr_2), 1 To 2)
For i = 1 To UBound(sArr_1)
   tmp = CStr(sArr_1(i, 2))
   Dic(tmp) = Empty
Next
For ii = 1 To UBound(sArr_2)
   tmp = CStr(sArr_2(ii, 2))
   If Dic.exists(tmp) Then
      k = k + 1
      Res(k, 1) = sArr_2(ii, 1)
      Res(k, 2) = sArr_2(ii, 2)
   End If
Next
[G2:H10000].ClearContents
If k Then [G2].Resize(k, 2) = Res Else MsgBox "No Data Found", vbInformation
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ, em cảm ơn anh nhiều ạ.
 
Upvote 0
quanghai1969 đã viết:
Khi nào cần nhanh thì xài code này
Mã: 
Sub Loc_Trung()
Dim Dic As Object, sArr_1(), sArr_2()
Dim Res(), k As Long, i As Long, ii As Long, tmp As String
Set Dic = CreateObject("scripting.dictionary")
sArr_1 = Range("A2", [A65536].End(3)).Resize(, 2).Value
sArr_2 = Range("D2", [D65536].End(3)).Resize(, 2).Value
ReDim Res(1 To UBound(sArr_2), 1 To 2)
For i = 1 To UBound(sArr_1)
   tmp = CStr(sArr_1(i, 2))
   Dic(tmp) = Empty
Next
For ii = 1 To UBound(sArr_2)
   tmp = CStr(sArr_2(ii, 2))
   If Dic.exists(tmp) Then
      k = k + 1
      Res(k, 1) = sArr_2(ii, 1)
      Res(k, 2) = sArr_2(ii, 2)
   End If
Next
[G2:H10000].ClearContents
If k Then [G2].Resize(k, 2) = Res Else MsgBox "No Data Found", vbInformation
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ, anh có thể giải thích giúp em đoạn code này để làm gì ạ?
For i = 1 To UBound(sArr_1)
tmp = CStr(sArr_1(i, 2))
Dic(tmp) = Empty
Next

Em thấy anh cho vòng lặp chạy qua bảng A nhưng lại cho Dic=Empty. Sau đó lại cho vòng lặp chạy qua bảng B nhưng em không hiểu đoạn code nào để dò các dữ liệu của bảng B trùng với bảng A ạ. Anh giải thích giúp em ạ. Em cảm ơn anh.
 
Upvote 0
Xem chú thích màu đỏ
thao nguyen01 đã viết:
Dạ, anh có thể giải thích giúp em đoạn code này để làm gì ạ?
For i = 1 To UBound(sArr_1) 'Duyệt qua bảng 1
tmp = CStr(sArr_1(i, 2)) 'Chuyển đổi dữ liệu về dạng text, đề phòng ổ gà ổ voi khi lội trong nước ngập
Dic(tmp) = Empty 'gán key vào công cụ Dic. Key= số hợp đồng, Item=Empty vì không có gì cần phải ghi nhớ
Next

Em thấy anh cho vòng lặp chạy qua bảng A nhưng lại cho Dic=Empty. Sau đó lại cho vòng lặp chạy qua bảng B nhưng em không hiểu đoạn code nào để dò các dữ liệu của bảng B trùng với bảng A ạ. Anh giải thích giúp em ạ. Em cảm ơn anh.
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
quanghai1969 đã viết:
Xem chú thích màu đỏ
Nhấp chuột vào đây để mở rộng...

Dạ, em cảm ơn anh ạ. Em hiểu đoạn đó rồi ạ.

Nhưng khi qua vòng lặp thứ 2 anh cho
tmp = CStr(sArr_2(ii, 2))
thì lại gán key mới theo bảng 2 ạ.

Như vậy
If Dic.exists(tmp) Then
.....
End if

Em hiểu theo key bảng 2, nên em không hiểu dò theo bảng A ở chỗ nào ạ. Em xin lỗi vì làm phiền anh ạ. Vì em mới tìm hiểu và không hiểu lắm ạ. Em cảm ơn anh ạ.
Bài đã được tự động gộp:

Dạ, em hiểu rồi ạ. Em cảm ơn anh @quanghai1969 nhiều ạ
 
Lần chỉnh sửa cuối:
Upvote 0
thao nguyen01 đã viết:
Em muốn lọc dữ liệu trùng nhau giữa 2 bảng bằng code VBA ạ (trùng tên và số hợp đồng ạ)
Nhấp chuột vào đây để mở rộng...
Có lẽ không cần kiểm tra trùng tên. Và tác giả quanghai1969 chỉ lưu "số hợp đồng".

Trong các lệnh
For i = 1 To UBound(sArr_1)
tmp = CStr(sArr_1(i, 2))
Dic(tmp) = Empty
Next
thì Dic(tmp) = Empty đã "nạp" thêm 1 thành phần có chỉ số là tmp và thành phần dữ liệu không có.

Cho nên (chú ý lệnh If )
For ii = 1 To UBound(sArr_2)
tmp = CStr(sArr_2(ii, 2))
If Dic.exists(tmp) Then

Thành phần sau lệnh IF là kiểm tra chỉ số tmp đã có (True), thì lưu thành phần trùng

Bạn nên chạy theo vết (gõ F8 trong cửa sổ edit code), và biết cách mở thêm cửa sổ chứa các tên biến và nội dung đang có trong biến thì thấy (đang chạy theo vết, chọn biến, chọn menu Debug>Add watch...

Viết thêm: Bạn cứ sửa tên 3 người đầu trong bảng 2 và chạy xem để thấy tác giả không xét cột 1
 
Upvote 0
haog_haonlh đã viết:
Có lẽ không cần kiểm tra trùng tên. Và tác giả quanghai1969 chỉ lưu "số hợp đồng".

Trong các lệnh
For i = 1 To UBound(sArr_1)
tmp = CStr(sArr_1(i, 2))
Dic(tmp) = Empty
Next
thì Dic(tmp) = Empty đã "nạp" thêm 1 thành phần có chỉ số là tmp và thành phần dữ liệu không có.

Cho nên (chú ý lệnh If )
For ii = 1 To UBound(sArr_2)
tmp = CStr(sArr_2(ii, 2))
If Dic.exists(tmp) Then

Thành phần sau lệnh IF là kiểm tra chỉ số tmp đã có (True), thì lưu thành phần trùng

Bạn nên chạy theo vết (gõ F8 trong cửa sổ edit code), và biết cách mở thêm cửa sổ chứa các tên biến và nội dung đang có trong biến thì thấy (đang chạy theo vết, chọn biến, chọn menu Debug>Add watch...

Viết thêm: Bạn cứ sửa tên 3 người đầu trong bảng 2 và chạy xem để thấy tác giả không xét cột 1
Nhấp chuột vào đây để mở rộng...

Mình cảm ơn bạn nhiều.
 
Upvote 0
VetMini đã viết:
Người dùng chỉ việc bấm nút, cớ chi mệt?
Người code thì coi như nó là tập thể dục hoặc giải trí. Đỡ tốn tiền chơi ghêm.
Nhấp chuột vào đây để mở rộng...
Dạ, lặp đi lặp lại nhiều lần thì code là tốt ạ, chứ code xong xài có 1 lần thì mệt thật đấy ạ! Mà kinh nghiệm cho thấy code cũng chỉ tốt cho người biết code thôi, chứ không biết gì về code, chỉ có sao xài vậy là đôi khi quá mệt luôn ạ!
 
Upvote 0
thao nguyen01 đã viết:
Kính gửi anh/chị trên diễn đàn,

Em muốn lọc dữ liệu trùng nhau giữa 2 bảng bằng code VBA ạ (trùng tên và số hợp đồng ạ). Nếu không có dữ liệu trùng, sẽ hiện thông báo "Không có dữ liệu trùng nhau" ạ. Anh chị xem giúp em ạ. Em cảm ơn nhiều ạ.
Nhấp chuột vào đây để mở rộng...
Bạn dùng ADODB xử lý cho nhanh

Chạy thủ tục:
DataDuplicate [A2], [D2], 2, [G2]
------------------
JavaScript: 
Sub DataDuplicate(Optional ByVal Table1 As Range, _
                  Optional ByVal Table2 As Range, _
                  Optional ByVal intColumn As Integer = 2, _
                  Optional ByVal RangeResult As Range)
  Dim LR1&, LR2&, rng As Range
  LR1 = Table1(1, 1).End(xlDown).Row - Table1(1, 1).Row + 1
  LR2 = Table2(1, 1).End(xlDown).Row - Table2(1, 1).Row + 1
  Dim D1 As String, D2 As String
  Set rng = Table1(1, 1).Resize(LR1, intColumn)
  D1 = " SELECT * FROM [" & rng.Parent.Name & "$" & rng.Address(0, 0) & "] TB1 "
  Set rng = Table2(1, 1).Resize(LR2, intColumn)
  D2 = " [" & rng.Parent.Name & "$" & rng.Address(0, 0) & "] TB2 "
  On Error Resume Next
  Dim CN As Object, Rs As Object
  Set CN = VBA.Interaction.CreateObject("ADODB.Connection")
  If Application.Version >= 12 Then
    CN.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source='" & rng.Parent.Parent.FullName & "';mode=Read;Extended properties=""Excel 12.0;HDR=No"";")
  Else
    CN.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & rng.Parent.Parent.FullName & "';mode=Read;Extended Properties=""Excel 8.0;HDR=No"";")
  End If
  Err.Clear
  Set Rs = CN.Execute(D1 & "INNER JOIN " & D2 & " ON TB1.F1 = TB2.F1 and TB1.F2 = TB2.F2")
  If Err.Number = 0 Then
    If Not Rs.EOF Then
       RangeResult.CopyFromRecordset Rs, , intColumn
    Else
      MsgBox "0"
    End If
  End If
  Rs.Close
  Set CN = Nothing: Set Rs = Nothing
Ends:
  On Error GoTo 0
End Sub
 
Upvote 0
HeSanbi đã viết:
Bạn dùng ADODB xử lý cho nhanh

Chạy thủ tục:
DataDuplicate [A2], [D2], 2, [G2]
------------------
JavaScript: 
Sub DataDuplicate(Optional ByVal Table1 As Range, _
                  Optional ByVal Table2 As Range, _
                  Optional ByVal intColumn As Integer = 2, _
                  Optional ByVal RangeResult As Range)
  Dim LR1&, LR2&, rng As Range
  LR1 = Table1(1, 1).End(xlDown).Row - Table1(1, 1).Row + 1
  LR2 = Table2(1, 1).End(xlDown).Row - Table2(1, 1).Row + 1
  Dim D1 As String, D2 As String
  Set rng = Table1(1, 1).Resize(LR1, intColumn)
  D1 = " SELECT * FROM [" & rng.Parent.Name & "$" & rng.Address(0, 0) & "] TB1 "
  Set rng = Table2(1, 1).Resize(LR2, intColumn)
  D2 = " [" & rng.Parent.Name & "$" & rng.Address(0, 0) & "] TB2 "
  On Error Resume Next
  Dim CN As Object, Rs As Object
  Set CN = VBA.Interaction.CreateObject("ADODB.Connection")
  If Application.Version >= 12 Then
    CN.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source='" & rng.Parent.Parent.FullName & "';mode=Read;Extended properties=""Excel 12.0;HDR=No"";")
  Else
    CN.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & rng.Parent.Parent.FullName & "';mode=Read;Extended Properties=""Excel 8.0;HDR=No"";")
  End If
  Err.Clear
  Set Rs = CN.Execute(D1 & "INNER JOIN " & D2 & " ON TB1.F1 = TB2.F1 and TB1.F2 = TB2.F2")
  If Err.Number = 0 Then
    If Not Rs.EOF Then
       RangeResult.CopyFromRecordset Rs, , intColumn
    Else
      MsgBox "0"
    End If
  End If
  Rs.Close
  Set CN = Nothing: Set Rs = Nothing
Ends:
  On Error GoTo 0
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ, em cảm ơn anh. Anh hướng dẫn em cách chạy với ạ. Em bỏ vô module1 bấm chạy thì hiện lên 1 bảng yêu cầu nhập Macro name ạ
Chạy thủ tục:
DataDuplicate [A2], [D2], 2, [G2]
 
Upvote 0
thao nguyen01 đã viết:
Dạ, em cảm ơn anh. Anh hướng dẫn em cách chạy với ạ. Em bỏ vô module1 bấm chạy thì hiện lên 1 bảng yêu cầu nhập Macro name ạ
Chạy thủ tục:
DataDuplicate [A2], [D2], 2, [G2]
Nhấp chuột vào đây để mở rộng...
JavaScript: 
Sub Run_DataDuplicate()
   DataDuplicate [A2], [D2], 2, [G2]
End Sub
 
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

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
805
VetMini
V
K
Nhờ mọi người hoàn thiện giúp công thức
Trả lời
4
Đọc
86
kiendt1973
K
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
0
Đọc
49
GPE-Trợ Lý
GPE-Trợ Lý
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
3
Đọc
92
dovanha1994
dovanha1994
N
Giúp sửa mã code
Trả lời
19
Đọc
399
ptm0412
ptm0412
P
Nhờ giúp đỡ hàm lọc dữ liệu theo tỉnh
Trả lời
10
Đọc
160
Parabol
P
CodyPham97
tạo biểu tượng thay thế nhấn đúp chuột
Trả lời
1
Đọc
47
BuiQuangThuan
B
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
54
HUONGHCKT
H
F
  • Question
Nhờ tư vấn cách tạo QR trong Excel
Trả lời
4
Đọc
443
hoangtuan.net
hoangtuan.net
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
7
Đọc
188
Ny Ny 2024
N
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
9
Đọc
455
bibuzz90
B
Nhật Anh 9x
  • Question
Tính tồn cuối kỳ luỹ kế cho nhiều mã
Trả lời
2
Đọc
94
Nhật Anh 9x
Nhật Anh 9x
H
Hỗ trợ lấy danh sách dữ liệu thỏa mãn điều kiện
Trả lời
1
Đọc
77
bebo021999
B
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
2
Trả lời
20
Đọc
560
ptm0412
ptm0412
nguyen trung cuong
File chứa marco không mở được.
Trả lời
2
Đọc
70
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
106
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
75
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
S
  • Question
Xin file excel bảng giá quần áo, trang phục, phụ kiện
Trả lời
2
Đọc
77
VetMini
V
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
19
Đọc
384
VetMini
V
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