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
214
Được thích
25
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

T
Hỏi về các tính tổng của một số theo thể thức tam giác pascal
Trả lời
9
Đọc
5K
Xphuonc
Xphuonc
LuuAnh980
Filter lọc có "mm" mà không thấy.
Trả lời
4
Đọc
94
LuuAnh980
LuuAnh980
H
Trích Lọc dữ liệu với Macro
Trả lời
18
Đọc
1K
HTN033
H
C
Giúp em viết công thức làm lịch thi đấu.
Trả lời
3
Đọc
89
VetMini
V
pupuchcha
  • Question
Viết code để tìm xích ma, mong mọi người giúp đỡ em ạ
Trả lời
4
Đọc
135
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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