Đây là code của bác SA_DQ. về việc so sánh cột. Nhưng em muốn biến dổi 1 chút. Nhưng sao nó chạy không nổi. Em mới chập chững với VBA. mông mọi người giúp em.


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
Dim Row As Long, Ii As Integer
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
Row = [A1].CurrentRegion.Rows.Count
For Ii = 1 To Row
Set Rng = Cells(Ii 1, 1).Resize(, Col)
For Each Clls In Rng
With Application.WorksheetFunction
For Jj = 1 To Col
Set Rng1 = Clls.Resize(Ii - 1 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
Next Ii
End Sub



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
Dim Row As Long, Ii As Integer
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
Row = [A1].CurrentRegion.Rows.Count
For Ii = 1 To Row
Set Rng = Cells(Ii 1, 1).Resize(, Col)
For Each Clls In Rng
With Application.WorksheetFunction
For Jj = 1 To Col
Set Rng1 = Clls.Resize(Ii - 1 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
Next Ii
End Sub
File đính kèm
Lần chỉnh sửa cuối:

