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

[thungdols]

Mong mọi người giúp đỡ. Xin lỗi vì em đã làm phiền.

 

[SA_DQ]

So sanh cac cot tai Sheet B1 voi cac cot sheet B2
Thay cot nao co du lieu trung khop nhau thi hien len gia tri (cac cot duoc to mau vang la trung khop nhau)
Mong mọi người giúp đỡ. Xin lỗi vì em đã làm phiền.

Không cần VBA gì ráo trọi, khẳng định rằng không có cột chứa dữ liệu nào trong 2 trang tính trùng luôn! Hãy xem lại đi nha.

 

[Hai Lúa Miền Tây]

Mong mọi người giúp đỡ. Xin lỗi vì em đã làm phiền.

Bạn chép code sau vào Module

Sub SoSanh2Sheet(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Dang tao bao cao..."
    Set rptWB = Workbooks.Add
    Application.DisplayAlerts = False
    While Worksheets.Count > 1
        Worksheets(2).Delete
    Wend
    Application.DisplayAlerts = True
    With ws1.UsedRange
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With ws2.UsedRange
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    DiffCount = 0
    For c = 1 To maxC
        Application.StatusBar = "So sanh cac cell " & Format(c / maxC, "0 %") & "..."
        For r = 1 To maxR
            cf1 = ""
            cf2 = ""
            On Error Resume Next
            cf1 = ws1.Cells(r, c).FormulaLocal
            cf2 = ws2.Cells(r, c).FormulaLocal
            On Error GoTo 0
            If cf1 <> cf2 Then
                DiffCount = DiffCount + 1
                Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
            End If
        Next r
    Next c
    Application.StatusBar = "Dang dinh dang bang tinh..."
    With Range(Cells(1, 1), Cells(maxR, maxC))
        .Interior.ColorIndex = 19
    On Error GoTo 0
    End With
    Columns("A:D").AutoFit
    rptWB.Saved = True
    If DiffCount = 0 Then
        rptWB.Close False
    End If
    Set rptWB = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Co " & DiffCount & " cell co noi dung khac nhau", vbInformation, _
        "So sanh giua " & ws1.Name & " voi " & ws2.Name
End Sub

Và chạy code sau nhé.

Sub SoSanh()
    SoSanh2Sheet Worksheets("b1"), Worksheets("b2")
End Sub

Bạn xem thêm file nhe.

 

[thungdols]

Mong Các bác xem lại hộ em. Vì em đã đánh dấu rõ ràng mà. 1 cột có 23 ô. Sự xuất hiện dữ liệu trong các cột W , cột AG . cột AN tại bảng B1 có dữ liệu xuất hiện trùng khớp với các cột tại bảng B2 đó là :
- Cột W có dữ liệu xuất hiện trùng với cột A
- Cột AG có dữ liệu xuất hiện trung với cột X
- Cột AN có dứ liệu xuất hiện trùng khớp với cột C
Mong bác thông cảm cho em vì sự diễn đạt kém cỏi. Cám ơn bác nhiều
Bài toán có nghĩa là lấy dữ liệu từng cột tại Sheet B1 so sánh với tất cả các cột tại sheet B2. Nếu thấy có sự trùng lặp dữ liệu thì hiện lên thông báo tại dòng 25 tương ứng của cột đó.

 

[Hai Lúa Miền Tây]

Mong sư phụ xem lại hộ em. Vì em đã đánh dấu rõ ràng mà. 1 cột có 23 ô. Sự xuất hiên dữ liệu trong các cột W , cột AG . cột AN tại bảng B1 có dữ liệu xuất hiện trùng khớp với các cột tại bảng B2 đó là :
-Cột W có dữ liệu xuất hiện trùng với cột A
- Cột AG có dữ liệu xuất hiện trung với cột X
-Cột AN có dứ liệu xuất hiện trùng khớp với cột C
Mong bác thông cảm cho em vì sự diễn đạt kém cỏi. Cám ơn bác nhiều

Chắc chắn dữ liệu của bạn không giống nhau. Lí do là nên sheet B1 có tiêu đề, sheet B2 không có nên so sánh cell sheet này và sheet kia không khớp.

 

[thungdols]

Chắc chắn dữ liệu của bạn không giống nhau. Lí do là nên sheet B1 có tiêu đề, sheet B2 không có nên so sánh cell sheet này và sheet kia không khớp.

Không phải thế đâu. Tại em kém trình bày nên gây ra lỗi như vậy. Thực chất range chỉ có 23 ô thôi không tính phần tiêu đề trong sheet B1. Cám ơn bác

 

[thungdols]

Bác domfootwear có yahoo không cho em liên lạc với bác được không. Xin lỗi vì em quấy quả bác. Thật sự là em ngưỡng mộ hết sức những thành viên trong GPE. Một lần nữa chân thành cảm ơn bác đã bớt chút thời gian vàng ngọc vì em

 

[SA_DQ]

Macro của bạn đây, xin mời; & lần sau không nên viết những gì mình hiểu

Option Explicit
Sub SoTrung()
 Dim Sh As Worksheet, Rng As Range, Clls As Range
 Dim Rw As Long, Col As Byte, Jj As Byte, Dem As Long, MyColor As Byte
 Dim Cll As Range, Rng1 As Range, Rng2 As Range
 
 Sheets("B1").Select:                  Set Sh = Sheets("B2")
 Sh.Cells.Interior.ColorIndex = 0:     Cells.Interior.ColorIndex = 0
 Rw = Sh.UsedRange.Rows.Count
 Application.ScreenUpdating = False
 Col = [A1].CurrentRegion.Columns.Count
 Set Rng = [A2].Resize(, Col)
 For Each Clls In Rng
   With Application.WorksheetFunction
      For Jj = 1 To Col
         Set Rng1 = Clls.Resize(Rw)
         Set Rng2 = Sh.Cells(1, Jj).Resize(Rw)
         If .Sum(Rng1) = .Sum(Rng2) Then
            Dem = 0
            For Each Cll In Rng1
               Dem = Dem + 1
               If Cll.Value <> Rng2.Cells(Dem, 1).Value Then Exit For
            Next Cll
            If Dem = Rw Then
               MyColor = 34 + Clls.Column Mod 6
               Clls.Interior.ColorIndex = MyColor
               Sh.Cells(1, Jj).Interior.ColorIndex = MyColor
            End If
         End If
      Next Jj
   End With
 Next Clls
End Sub

Mà phải viết để người khác hiểu ý mình!

 

[thungdols]

Cám ơn bác SA_DQ. Cái code của bác chay rất tuyệt chỉ duy nhất một cái em không hiểu là nó chỉ so sánh được cỡ 100 cột thôi. Làm sao để nó có thể so sánh được nhiều hơn nữa không ạ. Em chân thành cám ơn bác

 

[SA_DQ]

Chỉ là 0.266000000001542 gy

Cái code của bác chay nó chỉ so sánh được cỡ 100 cột thôi. Làm sao để nó có thể so sánh được nhiều hơn nữa không ạ. Em chân thành cám ơn bác

Trước khi chạy Code dưới đây bạn thử chép dữ liệu của B1 cho đến hơn 100 cột;
còn B2 bạn chép đến [FU23]
Hơn nữa, bạn chép cột [CM] của 'B1' sang [CN] của 'B2'

Sau khi chạy hãy cho biết trị đang chứa trong ô [B27] của 'B1' cái nha:

Option Explicit
Sub SoTrung()
 Dim Sh As Worksheet, Clls As Range, Cll As Range, Rng1 As Range, Rng2 As Range
 Dim Rw As Long, Col As Byte, Jj As Byte, Dem As Long, MyColor As Byte
 Dim Timer_ As Double
 
 Timer_ = Timer
 Sheets("B1").Select:                  Set Sh = Sheets("B2")
 Sh.Cells.Interior.ColorIndex = 0:     Cells.Interior.ColorIndex = 0
 Rw = Sh.UsedRange.Rows.Count
 Application.ScreenUpdating = False
 Col = [A1].CurrentRegion.Columns.Count
 For Each Clls In [A2].Resize(, Col)
   With Application.WorksheetFunction
      For Jj = 1 To Col
         Set Rng1 = Clls.Resize(Rw)
         Set Rng2 = Sh.Cells(1, Jj).Resize(Rw)
         If .Sum(Rng1) = .Sum(Rng2) Then
            Dem = 0
            For Each Cll In Rng1
               Dem = Dem + 1
               If Cll.Value <> Rng2.Cells(Dem, 1).Value Then Exit For
            Next Cll
            If Dem = Rw Then
               MyColor = 34 + Clls.Column Mod 6
               Clls.Interior.ColorIndex = MyColor
               Sh.Cells(1, Jj).Interior.ColorIndex = MyColor
            End If
         End If
      Next Jj
   End With
 Next Clls
 [B27].Value = Timer - Timer_
End Sub