So sánh giữa hai cột bằng VBA

thao nguyen01 · 15/1/21

Kính gửi anh/chị trên diễn đàn,

Em muốn so sánh giữa hai cột và tìm ra những mã khác nhau giữa hai cột. Nhưng em vướng vấn đề sau ạ:
-Số lượng ký tự giữa hai mã có thể khác nhau:
Ví dụ: mã 2 có số ký tự ít hơn nhưng vẫn đúng so với mã 1 (ký tự thiếu chỉ nằm bên trái, em ví dụ có dạng: *ABC) =>thì kết quả là không khác nhau (chỉ liệt kê những mã khác nhau hoặc không có ạ)

Anh/chị xem giúp em ạ. Em cảm ơn ạ.

Maika8008 · 16/1/21

thao nguyen01 đã viết:
Dạ, em cũng chưa hiểu cách anh @Maika8008 chạy 2 lần với đoạn code

For i = 1 To UBound(arrCF)
For j = 1 To UBound(arrF)
...
Next
Next

Nhưng kết quả ra đúng ạ.

Vì dữ liệu "lệch dòng", tức là không thể đoan chắc khi nào 1 phần tử bên mảng kia khớp với 1 phần tử bên mảng này nên phải dò đến khi nào KHÔNG KHỚP mới thôi. Đó là do tôi nghĩ vậy nên giải thuật có thể gây tốn thời gian. Chủ thớt cũng nên cân nhắc đánh giá.

P/S: tôi không dám nói gì nhưng với yêu cầu của chủ thớt, cả 2 cột dữ liệu đều có khả năng lạc mã và phải dò tìm, thì kết quả của bài #19 thế này, thớt xem thử;

thao nguyen01 · 16/1/21

Maika8008 đã viết:
Vì dữ liệu "lệch dòng", tức là không thể đoan chắc khi nào 1 phần tử bên mảng kia khớp với 1 phần tử bên mảng này nên phải dò đến khi nào KHÔNG KHỚP mới thôi. Đó là do tôi nghĩ vậy nên giải thuật có thể gây tốn thời gian. Chủ thớt cũng nên cân nhắc đánh giá.

Dạ. Em cảm ơn nhiều ạ.

VetMini · 16/1/21

Nếu tốc độ là điều cần thiết thì:

1. viết vòng lặp như thế nào để nếu có thể thì chấm dứt sớm, trước khi biến đếm vượt giới hạn cận trên (chấm dứt tự nhiên).

2. so chuỗi bằng hàm Instr thay cho toán tử Like

Riêng bài này thì nên Sort là tót nhất.

thao nguyen01 · 16/1/21

Maika8008 đã viết:
Vì dữ liệu "lệch dòng", tức là không thể đoan chắc khi nào 1 phần tử bên mảng kia khớp với 1 phần tử bên mảng này nên phải dò đến khi nào KHÔNG KHỚP mới thôi. Đó là do tôi nghĩ vậy nên giải thuật có thể gây tốn thời gian. Chủ thớt cũng nên cân nhắc đánh giá.

P/S: tôi không dám nói gì nhưng với yêu cầu của chủ thớt, cả 2 cột dữ liệu đều có khả năng lạc mã và phải dò tìm, thì kết quả của bài #19 thế này, thớt xem thử;
View attachment 253093

Dạ, em mới xem kết quả lại nếu dùng code của anh thì không có kết quả của "Z9L3875644" và "Z9L3875644Z" vì thực tế giống nhau. Khi em kiểm tra dữ liệu của anh, em mới thấy ạ. Vì dữ liệu của em đưa ra là dạng *ABC nên em không thấy trường hợp này khi em xem code bài #19. Code của anh là dạng *ABC* ạ.

VetMini · 17/1/21

Đính chính cho bài #23: sort là giải thuật không đúng !
Ở bài #23, tôi nói "bài này nên sort" là hơi hấp tấp. Sau khi phân tích lại, tôi nhận ra nếu so sánh *abc = abc thì sort chả có công dụng gì cả.

HieuCD · 17/1/21

VetMini đã viết:
Đính chính cho bài #23: sort là giải thuật không đúng !
Ở bài #23, tôi nói "bài này nên sort" là hơi hấp tấp. Sau khi phân tích lại, tôi nhận ra nếu so sánh *abc = abc thì sort chả có công dụng gì cả.

Dùng hàm đảo ngược ký tự rồi sort

HieuCD · 18/1/21

thao nguyen01 đã viết:
Dạ, dữ liệu thật khoảng 10000 dòng ạ.

Code với vài trăm nghìn dòng

Mã:

Sub XYZ()
  Dim Arr(), Arr2(), Res() As String, t
  Dim i&, i2&, k&, k2&, sR&, sR2&, sRow&, ma$, ma2$
    
  t = Timer
  With Sheet1
    Arr = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Value
    Arr2 = .Range("D3", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
  Call SortArrayList(Arr, Arr)
  Call SortArrayList(Arr2, Arr2)
  sR = UBound(Arr): sR2 = UBound(Arr2)
  If sR > sR2 Then sRow = sR Else sRow = sR2
  ReDim Res(1 To sRow, 1 To 2)
 
  i = 1: i2 = 1
  ma = Arr(i, 1): ma2 = Arr2(i2, 1)
  Do
    If ma Like ma2 & "*" Or ma2 Like ma & "*" Then
      Arr(i, 1) = Empty: Arr2(i2, 1) = Empty
      If i = sR Or i2 = sR2 Then Exit Do
      i = i + 1: i2 = i2 + 1
      ma = Arr(i, 1): ma2 = Arr2(i2, 1)
    Else
      If ma > ma2 Then
        If i2 = sR2 Then Exit Do
        i2 = i2 + 1: ma2 = Arr2(i2, 1)
      Else
        If i = sR Then Exit Do
        i = i + 1: ma = Arr(i, 1)
      End If
    End If
  Loop
 
  For i = 1 To sR
    If Arr(i, 1) <> Empty Then
      k = k + 1
      Res(k, 1) = StrReverse(Arr(i, 1))
    End If
  Next i
  For i2 = 1 To sR2
    If Arr2(i2, 1) <> Empty Then
      k2 = k2 + 1
      Res(k2, 2) = StrReverse(Arr2(i2, 1))
    End If
  Next i2
 
  With Sheet1
    i = .Range("G" & Rows.Count).End(xlUp).Row
    i2 = .Range("H" & Rows.Count).End(xlUp).Row
    If i2 > i Then i = i2
    If i > 2 Then .Range("G3").Resize(i, 2).ClearContents
    If k2 > k Then k = k2
    If k > 0 Then .Range("F3").Resize(k, 2).Value = Res
  End With
  MsgBox ("Thoi gian chay code:  " & Timer - t & "giay")
 End Sub
 
 Private Sub SortArrayList(ByRef ResSort As Variant, ByVal sArrSort As Variant)
  Dim oArrList As Object, iKey$, i&, k&, fRow&, eRow&

  Set oArrList = CreateObject("System.Collections.ArrayList")
  fRow = LBound(sArrSort, 1): eRow = UBound(sArrSort, 1)
  ReDim ResSort(1 To eRow - fRow + 1, 1 To 1)
  For i = fRow To eRow
    iKey = sArrSort(i, 1)
    'If iKey <> Empty Then oArrList.Add iKey
    If iKey <> Empty Then oArrList.Add StrReverse(iKey)
  Next i
  oArrList.Sort
  eRow = oArrList.Count - 1
  For i = 0 To eRow
    k = k + 1
    ResSort(k, 1) = oArrList.Item(i)
  Next i
  Set oArrList = Nothing
End Sub

thao nguyen01 · 18/1/21

HieuCD đã viết:

Code với vài trăm nghìn dòng

Mã:

Sub XYZ()
  Dim Arr(), Arr2(), Res() As String, t
  Dim i&, i2&, k&, k2&, sR&, sR2&, sRow&, ma$, ma2$
   
  t = Timer
  With Sheet1
    Arr = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Value
    Arr2 = .Range("D3", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
  Call SortArrayList(Arr, Arr)
  Call SortArrayList(Arr2, Arr2)
  sR = UBound(Arr): sR2 = UBound(Arr2)
  If sR > sR2 Then sRow = sR Else sRow = sR2
  ReDim Res(1 To sRow, 1 To 2)

  i = 1: i2 = 1
  ma = Arr(i, 1): ma2 = Arr2(i2, 1)
  Do
    If ma Like ma2 & "*" Or ma2 Like ma & "*" Then
      Arr(i, 1) = Empty: Arr2(i2, 1) = Empty
      If i = sR Or i2 = sR2 Then Exit Do
      i = i + 1: i2 = i2 + 1
      ma = Arr(i, 1): ma2 = Arr2(i2, 1)
    Else
      If ma > ma2 Then
        If i2 = sR2 Then Exit Do
        i2 = i2 + 1: ma2 = Arr2(i2, 1)
      Else
        If i = sR Then Exit Do
        i = i + 1: ma = Arr(i, 1)
      End If
    End If
  Loop

  For i = 1 To sR
    If Arr(i, 1) <> Empty Then
      k = k + 1
      Res(k, 1) = StrReverse(Arr(i, 1))
    End If
  Next i
  For i2 = 1 To sR2
    If Arr2(i2, 1) <> Empty Then
      k2 = k2 + 1
      Res(k2, 2) = StrReverse(Arr2(i2, 1))
    End If
  Next i2

  With Sheet1
    i = .Range("G" & Rows.Count).End(xlUp).Row
    i2 = .Range("H" & Rows.Count).End(xlUp).Row
    If i2 > i Then i = i2
    If i > 2 Then .Range("G3").Resize(i, 2).ClearContents
    If k2 > k Then k = k2
    If k > 0 Then .Range("F3").Resize(k, 2).Value = Res
  End With
  MsgBox ("Thoi gian chay code:  " & Timer - t & "giay")
End Sub

Private Sub SortArrayList(ByRef ResSort As Variant, ByVal sArrSort As Variant)
  Dim oArrList As Object, iKey$, i&, k&, fRow&, eRow&

  Set oArrList = CreateObject("System.Collections.ArrayList")
  fRow = LBound(sArrSort, 1): eRow = UBound(sArrSort, 1)
  ReDim ResSort(1 To eRow - fRow + 1, 1 To 1)
  For i = fRow To eRow
    iKey = sArrSort(i, 1)
    'If iKey <> Empty Then oArrList.Add iKey
    If iKey <> Empty Then oArrList.Add StrReverse(iKey)
  Next i
  oArrList.Sort
  eRow = oArrList.Count - 1
  For i = 0 To eRow
    k = k + 1
    ResSort(k, 1) = oArrList.Item(i)
  Next i
  Set oArrList = Nothing
End Sub

Dạ, em cảm ơn Thầy nhiều ạ

Quang_Hải · 1/2/21

thao nguyen01 đã viết:
Em cảm ơn anh @Maika8008 , Thầy @HieuCD và Bác @batman1 đã xem bài của em ạ.

Dạ, lỗi này do em không mô tả kỹ ạ. Dữ liệu của em nằm lệch dòng và không phải lúc nào cũng ở dạng mã 2 ít hơn mã 1 ạ. Em thấy chỉ đúng với dạng *ABC thôi ạ. Vì do người nhập không thống nhất với nhau, mỗi người nhập lấy số ký tự không thống nhất, nên khi dò tìm khá cực và mất nhiều thời gian. Em đã thử làm thủ công nhưng mất nhiều thời gian mà em không thể kiểm soát là có sót không. Trong thời gian tới em nghĩ sẽ điều chỉnh lại nhưng vì hiện tại cần xử lý những dữ liệu quá khứ nên em mong các Thầy, anh/chị trên diễn đàn xem giúp em ạ. Em cảm ơn nhiều ạ

Em xin mô tả lại:
Em muốn tìm những mã khác nhau giữa hai cột (Những mã có ở cột B nhưng không có ở cột D và ngược lại). Dữ liệu lệch dòng.

Nếu số lượng ký tự giữa hai mã khác nhau:

Ví dụ: mã 2 có số ký tự ít hơn nhưng vẫn đúng so với mã 1 thì kết quả là không khác nhau hay ngược lại (số lượng ký tự mã 2 >số lượng ký tự mã 1 và ngược lại)

Bạn thử code này xem coi thế nào. Đã thử chạy với dữ liệu 100 000 dòng, tốc độ khoảng 3 giây trên máy của mình
Lưu ý: theo mô tả của bạn thì dữ liệu có dạng *1234567, nên nếu cần thiết thì hãy thay NumOfStr=7 thành 8, hay 9 ... cho phù hợp thực tế
Code này không có xóa kết quả trước đó, hãy xóa thủ công trước khi chạy code
Nếu code không phù hợp yêu cầucủa bạn, hãy coi như tham khảo thuật toán nhé

Mã:

Sub So_Sanh()
Dim sArr1(), sArr2(), i As Long, tmp As String, k As Long, kk As Long
Dim sh As Worksheet, Res1(), Res2(), NumOfStr As Long
Dim Dic1 As Object, Dic2 As Object
Set Dic1 = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")
Set sh = Sheets("Sheet1")
NumOfStr = 7
sArr1 = sh.Range("B3", sh.Range("B" & Rows.Count).End(3)).Value
sArr2 = sh.Range("D3", sh.Range("D" & Rows.Count).End(3)).Value
ReDim Res1(1 To UBound(sArr2), 1 To 1)
ReDim Res2(1 To UBound(sArr1), 1 To 1)
For i = 1 To UBound(sArr1)
   tmp = Right(UCase(sArr1(i, 1)), NumOfStr)
   Dic1(tmp) = Empty
Next
For i = 1 To UBound(sArr2)
   tmp = Right(UCase(sArr2(i, 1)), NumOfStr)
   Dic2(tmp) = Empty
Next
For i = 1 To UBound(sArr1)
   tmp = Right(UCase(sArr1(i, 1)), NumOfStr)
   If Not Dic2.exists(tmp) Then
      k = k + 1
      Res1(k, 1) = sArr1(i, 1)
   End If
Next
For i = 1 To UBound(sArr2)
   tmp = Right(UCase(sArr2(i, 1)), NumOfStr)
   If Not Dic1.exists(tmp) Then
      kk = kk + 1
      Res2(kk, 1) = sArr2(i, 1)
   End If
Next
If k Then sh.[G3].Resize(k) = Res1
If kk Then sh.[H3].Resize(kk) = Res2
End Sub

thao nguyen01 · 1/2/21

Quang_Hải đã viết:
Bạn thử code này xem coi thế nào. Đã thử chạy với dữ liệu 100 000 dòng, tốc độ khoảng 3 giây trên máy của mình
Lưu ý: theo mô tả của bạn thì dữ liệu có dạng *1234567, nên nếu cần thiết thì hãy thay NumOfStr=7 thành 8, hay 9 ... cho phù hợp thực tế
Code này không có xóa kết quả trước đó, hãy xóa thủ công trước khi chạy code
Nếu code không phù hợp yêu cầucủa bạn, hãy coi như tham khảo thuật toán nhé

Mã:

Sub So_Sanh() Dim sArr1(), sArr2(), i As Long, tmp As String, k As Long, kk As Long Dim sh As Worksheet, Res1(), Res2(), NumOfStr As Long Dim Dic1 As Object, Dic2 As Object Set Dic1 = CreateObject("scripting.dictionary") Set Dic2 = CreateObject("scripting.dictionary") Set sh = Sheets("Sheet1") NumOfStr = 7 sArr1 = sh.Range("B3", sh.Range("B" & Rows.Count).End(3)).Value sArr2 = sh.Range("D3", sh.Range("D" & Rows.Count).End(3)).Value ReDim Res1(1 To UBound(sArr2), 1 To 1) ReDim Res2(1 To UBound(sArr1), 1 To 1) For i = 1 To UBound(sArr1) tmp = Right(UCase(sArr1(i, 1)), NumOfStr) Dic1(tmp) = Empty Next For i = 1 To UBound(sArr2) tmp = Right(UCase(sArr2(i, 1)), NumOfStr) Dic2(tmp) = Empty Next For i = 1 To UBound(sArr1) tmp = Right(UCase(sArr1(i, 1)), NumOfStr) If Not Dic2.exists(tmp) Then k = k + 1 Res1(k, 1) = sArr1(i, 1) End If Next For i = 1 To UBound(sArr2) tmp = Right(UCase(sArr2(i, 1)), NumOfStr) If Not Dic1.exists(tmp) Then kk = kk + 1 Res2(kk, 1) = sArr2(i, 1) End If Next If k Then sh.[G3].Resize(k) = Res1 If kk Then sh.[H3].Resize(kk) = Res2 End Sub

Dạ, kết quả ra đúng ạ. Em cảm ơn anh nhiều ạ.

So sánh giữa hai cột bằng VBA

thao nguyen01

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

File đính kèm

Maika8008

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

thao nguyen01

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

VetMini

Ăn cùng góc phố

thao nguyen01

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

VetMini

Ăn cùng góc phố

HieuCD

Chuyên gia GPE

HieuCD

Chuyên gia GPE

thao nguyen01

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

Quang_Hải

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

thao nguyen01

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