Option Explicit
''******************************************************************************************
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
''******************************************************************************************
Private Type POINTAPI
x As Long
y As Long
End Type
''******************************************************************************************
Private Cancel As Boolean
''******************************************************************************************
Sub ChangeCellColor()
On Error Resume Next
Dim pt As POINTAPI
Dim RowsColor(), ColsColor(), RowsBoolean(), ColsBoolean(), _
LastColRange As Range, CurrColRange As Range, _
LastRowRange As Range, CurrRowRange As Range, _
LastCell As Range, CurrCell As Range
Dim StartRow As Long, EndRow As Long, StartCol As Long, EndCol As Long, _
LastRow As Long, CurrRow As Long, LastCol As Long, CurrCol As Long, _
RowColor As Long, ColColor As Long, MidColor As Long, _
c As Long, r As Long, ir As Long, ic As Long
[COLOR=#ff0000][B] ''Muon thay doi so HANG? Tai day:[/B][/COLOR]
StartRow = 5: EndRow = 24
[COLOR=#ff0000][B] ''Muon thay doi so COT? Tai day:[/B][/COLOR]
StartCol = 3: EndCol = 27
[B][COLOR=#ff0000] ''Muon thay doi Interior.Color? Tai day:[/COLOR][/B]
RowColor = 13408767: ColColor = 10079487: MidColor = 65280
ir = StartRow - 1: ic = StartCol - 1
ReDim RowsColor(StartCol To EndCol)
ReDim RowsBoolean(StartCol To EndCol)
ReDim ColsColor(StartRow To EndRow)
ReDim ColsBoolean(StartRow To EndRow)
Cancel = False
Do
[COLOR=#ff0000][B] ''Gioi han SHEET can tao hieu ung:[/B][/COLOR]
If ActiveSheet.Name <> "TrongNghia" Then Exit Sub
GetCursorPos pt
Set CurrCell = ActiveWindow.RangeFromPoint(pt.x, pt.y)
If Not CurrCell Is Nothing Then
If Not Intersect(CurrCell, Range(Cells(StartRow, StartCol), Cells(EndRow, EndCol))) Is Nothing Then
If LastCell Is Nothing Then
CurrRow = CurrCell.Row
CurrCol = CurrCell.Column
[COLOR=#008000] ''Xac dinh Hang:[/COLOR]
Set CurrRowRange = Range(Cells(CurrRow, StartCol), Cells(CurrRow, EndCol))
For c = StartCol To EndCol
If CurrRowRange(c - ic).Interior.Pattern = xlNone Then
RowsBoolean(c) = False
Else
RowsBoolean(c) = True
RowsColor(c) = CurrRowRange(c - ic).Interior.Color
End If
Next
[COLOR=#008000] ''Xac dinh Cot:[/COLOR]
Set CurrColRange = Range(Cells(StartRow, CurrCol), Cells(EndRow, CurrCol))
For r = StartRow To EndRow
If CurrColRange(r - ir).Interior.Pattern = xlNone Then
ColsBoolean(r) = False
Else
ColsBoolean(r) = True
ColsColor(r) = CurrColRange(r - ir).Interior.Color
End If
Next
CurrRowRange.Interior.Color = RowColor
CurrColRange.Interior.Color = ColColor
CurrCell.Interior.Color = MidColor
Set LastRowRange = CurrRowRange
Set LastColRange = CurrColRange
Set LastCell = CurrCell
Else
If CurrCell.Address <> LastCell.Address Then
CurrRow = CurrCell.Row
CurrCol = CurrCell.Column
For c = StartCol To EndCol
If RowsBoolean(c) = True Then
LastRowRange(c - ic).Interior.Color = RowsColor(c)
Else
LastRowRange(c - ic).Interior.Pattern = xlNone
End If
Next
For r = StartRow To EndRow
If ColsBoolean(r) = True Then
LastColRange(r - ir).Interior.Color = ColsColor(r)
Else
LastColRange(r - ir).Interior.Pattern = xlNone
End If
Next
Set CurrRowRange = Range(Cells(CurrRow, StartCol), Cells(CurrRow, EndCol))
For c = StartCol To EndCol
If CurrRowRange(c - ic).Interior.Pattern = xlNone Then
RowsBoolean(c) = False
Else
RowsBoolean(c) = True
RowsColor(c) = CurrRowRange(c - ic).Interior.Color
End If
Next
Set CurrColRange = Range(Cells(StartRow, CurrCol), Cells(EndRow, CurrCol))
For r = StartRow To EndRow
If CurrColRange(r - ir).Interior.Pattern = xlNone Then
ColsBoolean(r) = False
Else
ColsBoolean(r) = True
ColsColor(r) = CurrColRange(r - ir).Interior.Color
End If
Next
CurrRowRange.Interior.Color = RowColor
CurrColRange.Interior.Color = ColColor
CurrCell.Interior.Color = MidColor
Set LastRowRange = CurrRowRange
Set LastColRange = CurrColRange
Set LastCell = CurrCell
End If
End If
Else
If Not LastCell Is Nothing Then
For c = StartCol To EndCol
If RowsBoolean(c) = True Then
LastRowRange(c - ic).Interior.Color = RowsColor(c)
Else
LastRowRange(c - ic).Interior.Pattern = xlNone
End If
Next
For r = StartRow To EndRow
If ColsBoolean(r) = True Then
LastColRange(r - ir).Interior.Color = ColsColor(r)
Else
LastColRange(r - ir).Interior.Pattern = xlNone
End If
Next
End If
End If
End If
DoEvents
Loop Until Cancel = True
End Sub
''******************************************************************************************
Sub CancelProcedure()
Cancel = True
End Sub
''******************************************************************************************
pen có các lệnh để tạo ra nút lệnh này nên khi mở file ra là bạn sẽ nhìn thấy tab Add-Ins.
haha! Anh Phúc, vậy mà cũng vui tính thiệt đó!
