Hỏi. Tô màu cho ô với điều kiện

[xda1811]

Mong các anh bớt chút thời gian nghĩ giùm em. em mới tham gia diễn đàn kiến thức còn hạn hẹp, mà công việc của em cần đến excel quá, kiến thức về VBA,macro thì em không có . Các sư huynh làm giúp em cái tool này với
em gửi file đính kèm
em muốn như sau :
1. tính theo cột giả sử là cột V trong file đính kèm
tính từ ô V5 đến V17 nếu toàn là ký tự * thì sẽ có màu xanh ( Nếu từ 8 đến 15 ô liên tiếp nhau là ký tự * thì được bôi màu xanh )
2. tương tự cột T
tính từ ô T24 đến T43
liên tiếp là dấu * em muốn là màu tím than ( Nếu từ 16 đến 25 ô liên tiếp nhau là ký tự * thì được bôi màu màu tím than )
3.tương tự với cột M
tính từ ô M11 đến M35 liên tiếp là dấu * em muốn là màu nâu ( Nếu từ 26 đến 40 ô liên tiếp nhau là ký tự * thì được bôi màu nâu )

Mong các anh hướng dẫn cụ thể, chi tiết cho em
Cảm ơn các sư huynh, chúc các sư huynh luôn mạnh khỏe

 

[ChanhTQ@]

Trong nổ lực giảm thiểu thời gian

Các bạn thử xem cái con macro này tốc độ ra sao?

Option Explicit
Sub ToMau()
 Const DS As String = "*"
 Dim Cols As Byte, zZ As Byte, dSao As Byte, bColor As Variant
 Dim Rws As Long, Ff As Long:               Dim Timer_ As Double
 
 Timer_ = Timer
 Cols = [iV2].End(xlToLeft).Column:         Application.ScreenUpdating = False
 Rws = [A65500].End(xlUp).Row:              [b2].CurrentRegion.ClearFormats
 For zZ = 1 To Cols
    dSao = 0
    For Ff = 1 To Rws
        With Cells(Ff, zZ)
            If .Value = DS And dSao = 0 Then
                dSao = 1
            ElseIf .Value = DS And dSao > 0 Then
                dSao = dSao + 1
            ElseIf .Value <> DS And dSao > 7 Then
                .Offset(-1).Value = DS & dSao
                bColor = Switch(dSao < 16, 42, dSao < 26, 13, dSao < 41, 54)
                With .Offset(-dSao).Resize(dSao).Interior
                    .ColorIndex = bColor
                End With
                dSao = 0
            ElseIf .Value <> DS And dSao < 8 Then
                dSao = 0
            End If
        End With
    Next Ff
 Next zZ
 Cells(1, Cols + 2) = Timer - Timer_
End Sub

 

[ptm0412]

Các bạn thử xem cái con macro này tốc độ ra sao?

test trên cùng 1 máy, bác ChanhTQ ạ, của em là 4.5625 giây, của Bác là 6.265625 giây. Khổ nỗi chủ đầu tư nhà mình lại yêu cầu ô nào của họ có màu đỏ, phải giữ nguyên màu đỏ cơ. nên em phải thêm vào cái câu này:
If Cells(j, i).Interior.ColorIndex <> 3 Then Cells(j, i).Interior.ColorIndex = xlNone
Nó làm tăng thêm ít nhất là 35 giây.
Có điều chủ đầu tư nói chậm 1 chút cũng được, nên em để nguyên thế.

Còn nữa:
1. code của Bác sẽ không tô màu cuối cột, dù cho có bao nhiêu dấu sao đi nữa. Cái này em đã bị rồi.
2. Sau mỗi lần chạy, số ô đếm được của bác bị giảm đi 1, cái này em cũng đã bị.

Bác xem hình, vùng đang được chọn là vùng không tô màu, các vùng đã tô màu là vùng đã bị ngắn lại sau lần chạy thứ 9. Em nào ngắn lại chỉ còn 7 là thua luôn.

Còn code của em thì tô tuốt tuồn tuột:

 

[ptm0412]

Học Bác Chanh hàm Switch(), và sửa lỗi tô sai màu ở cuối cột

Sub ColorFill(Color1 As Long, Color2 As Long, Color3 As Long)
Application.ScreenUpdating = False
Sheet2.Cells(1, 3) = Timer
EndCol = Range("IV1").End(xlToLeft).Column
EndRow = Range("A65536").End(xlUp).Row
For i = 1 To EndCol
    k = 0
    For j = 1 To EndRow
        If Cells(j, i).Interior.ColorIndex <> 3 Then Cells(j, i).Interior.ColorIndex = xlNone
        Check = Left(Trim(Cells(j, i)), 1)
        If Check = Chr(42) Then k = k + 1
        If k < 8 And Check <> Chr(42) Then k = 0
        If k >= 8 And Check <> Chr(42) Then
            ColorCode = Switch(k < 16, Color1, k < 26, Color2, k > 25, Color3)
            Range(Cells(j - k, i), Cells(j - 1, i)).Interior.ColorIndex = ColorCode
            Cells(j - 1, i) = Chr(42) & k
            k = 0
        End If
        If k >= 8 And j = EndRow And Check = Chr(42) Then
            ColorCode = Switch(k < 16, Color1, k < 26, Color2, k > 25, Color3)
            Range(Cells(j - k + 1, i), Cells(j, i)).Interior.ColorIndex = ColorCode
            Cells(j, i) = Chr(42) & k
            k = 0
        End If
   Next j
Next i
Sheet2.Cells(2, 3) = Timer
Application.ScreenUpdating = True

 

[ChanhTQ@]

Đã sửa theo góp í của PTM (#22), thời gian bị dài ra thêm

Option Explicit
Sub ToMau()
 Const DS As String = "*"
 Dim Cols As Byte, zZ As Byte, dSao As Byte, bColor As Variant
 Dim Rws As Long, Ff As Long:               Dim Timer_ As Double
 
 Timer_ = Timer
 Cols = [iV2].End(xlToLeft).Column:         Application.ScreenUpdating = False
 Rws = [A65500].End(xlUp).Row + 1:         ' [b2].CurrentRegion.ClearFormats'
 For zZ = 1 To Cols
    dSao = 0
    For Ff = 1 To Rws
        With Cells(Ff, zZ)
            If Left(.Value, 1) = DS Then    '*'
                dSao = dSao + 1
            ElseIf Left(.Value, 1) <> DS And dSao > 7 Then
                .Offset(-1).Value = DS & dSao
                bColor = Switch(dSao < 16, 42, dSao < 26, 13, dSao < 41, 54)
                With .Offset(-dSao).Resize(dSao).Interior
                    .ColorIndex = bColor
                End With
                dSao = 0
            ElseIf Left(.Value, 1) <> DS And dSao < 8 Then
                dSao = 0
            End If
        End With
    Next Ff
 Next zZ
 Cells(1, Cols + 2) = Timer - Timer_
End Sub

 

[ptm0412]

Bác thêm vào 1 dòng nó tăng thêm thời gian là phải, Bác ạ.
Còn cái vụ không clear format ô nào cũng khổ lắm Bác ơi, nhỡ chủ đầu tư bớt hoặc sửa dữ liệu và chạy lại code, các ô lúc trước lỡ tô màu, bi giờ không thoả điều kiện nữa nhưng màu thì còn hoài.

 

[xda1811]

Bác thêm vào 1 dòng nó tăng thêm thời gian là phải, Bác ạ.
Còn cái vụ không clear format ô nào cũng khổ lắm Bác ơi, nhỡ chủ đầu tư bớt hoặc sửa dữ liệu và chạy lại code, các ô lúc trước lỡ tô màu, bi giờ không thoả điều kiện nữa nhưng màu thì còn hoài.

sư phụ xem lại cho em với. sao em ấn ctrl + T mà nó chẳng chạy gì? không biết em có nhầm chỗ nào không ?

Sub ColorFill(Color1 As Long, Color2 As Long, Color3 As Long)
Application.ScreenUpdating = False
Sheet2.Cells(1, 3) = Timer
EndCol = Range("IV1").End(xlToLeft).Column
EndRow = Range("A65536").End(xlUp).Row
For i = 1 To EndCol
    k = 0
    For j = 1 To EndRow
        If Cells(j, i).Interior.ColorIndex <> 3 Then Cells(j, i).Interior.ColorIndex = xlNone
        Check = Left(Trim(Cells(j, i)), 1)
        If Check = Chr(42) Then k = k + 1
        If k < 8 And Check <> Chr(42) Then k = 0
        If k >= 8 And Check <> Chr(42) Then
            Select Case k
            Case 8 To 15
                ColorCode = Color1
            Case 16 To 25
                ColorCode = Color2
            Case Is > 15
                ColorCode = Color3
            End Select
            Range(Cells(j - k, i), Cells(j - 1, i)).Interior.ColorIndex = ColorCode
            Cells(j - 1, i) = Chr(42) & k
            k = 0
        End If
        If k >= 8 And j = EndRow And Check = Chr(42) Then
            Range(Cells(j - k + 1, i), Cells(j, i)).Interior.ColorIndex = ColorCode
            Cells(j - 1, i) = Chr(42) & k
            k = 0
        End If
   Next j
Next i
Sheet2.Cells(2, 3) = Timer
Application.ScreenUpdating = True
End Sub

 

[ptm0412]

Down file này về nè, lần sau cứ thế mà xài thôi. nếu có sự cố gì thì đừng làm gì cả, gọi ĐT cho anh là được: 09 19 77 2142

 

[ChanhTQ@]

Sai đâu sửa đó; sửa đó sai đâu?

Còn cái vụ không clear format ô nào cũng khổ lắm Bác ơi, nhỡ chủ đầu tư bớt hoặc sửa dữ liệu và chạy lại code, các ô lúc trước lỡ tô màu, bi giờ không thoả điều kiện nữa nhưng màu thì còn hoài.

Option Explicit
Sub ToMau()
 Const DS As String = "*"
 Dim Cols As Byte, zZ As Byte, dSao As Byte, bColor As Variant
 Dim Rws As Long, Ff As Long:               Dim Timer_ As Double
 
 Timer_ = Timer
 Cols = [iV2].End(xlToLeft).Column:         Application.ScreenUpdating = False
 Rws = [A65500].End(xlUp).Row + 1
 [b2].CurrentRegion.SpecialCells(xlCellTypeConstants, 2).ClearFormats
 For zZ = 1 To Cols
    dSao = 0
    For Ff = 1 To Rws
        With Cells(Ff, zZ)
            If Left(.Value, 1) = DS Then    '*'
                dSao = dSao + 1
            ElseIf Left(.Value, 1) <> DS And dSao > 7 Then
                .Offset(-1).Value = DS & dSao
                bColor = Switch(dSao < 16, 42, dSao < 26, 13, dSao < 41, 54)
                With .Offset(-dSao).Resize(dSao).Interior
                    .ColorIndex = bColor
                End With
                dSao = 0
            ElseIf Left(.Value, 1) <> DS And dSao < 8 Then
                dSao = 0
            End If
        End With
    Next Ff
 Next zZ
 Cells(1, Cols + 2) = Timer - Timer_
End Sub

Máy của PTM mạnh thiệt đó; "Một bước thỏ = 5 bước rùa!"
Nhờ bạn xem xét, test & cho í kiến tiếp, xin cảm ơn nhiều nha!

 

[ptm0412]

Thưa Bác, hôm nay thử trên máy công ty, của em 70.04588 giây, của Bác 80.704 giây. Mà sao nó lại xoá cả format các ô đỏ nhỉ?

Em thử chạy câu này trong immediate:

[b2].CurrentRegion.SpecialCells(xlCellTypeConstants, 2).ClearFormats

Thì bị xoá màu tất tần tật

Thế mà tô chọn 1 vùng nhỏ và dùng câu này:

Selection.SpecialCells(xlCellTypeConstants, 2).ClearFormats

Thì các ô số màu đỏ còn nguyên?
________________________

Về thử lại máy nhà: Code của bác nhanh hơn: 21.46 giây, của em 33.925 giây.
Nhưng sao vẫn bị mất màu đỏ hết tơn hết tọi?

 

[xda1811]

Em chào các anh
anh PT cho em hỏi thêm 1 chút nữa. em muốn thêm mấy điều kiện vào macro hôm trước anh giúp em

1. nếu gặp ô màu đỏ thì phía dưới nó sẽ hiện màu vàng và đếm số thứ tự đến khi có dữ liệu . ( em làm bằng tay ở file excel gửi kèm ).
Nếu sau ô màu đỏ > 8 ô mà ko có dữ liệu thì vẫn để màu xanh như cũ

2.nếu 2 hoặc 3 ô liên tiếp có dữ liệu thì được bôi màu xanh
anh giúp em với nhé
cảm ơn anh nhiều lắm

 

[ptm0412]

Tô màu kiểu 2

File đã xong.
Vì lần này đổi dấu * thành số từ 1 đến hết, nên không chạy lại lần 2, lần 3 như tô màu kiểu kia c nữa. Do đó phải sao lưu trước khi chạy.

Có thể làm 1 code để undo nhưng để sau nha. Hoặc nếu muốn thì kết hợp luôn, xóa màu tô cũ, đổi số thành *, tô lại. (Vì chưa biết cụ thể em muốn gì)

Còn bây giờ chịu khó thử trên file copy thôi. Thử 1 lần, copy lại dữ liệu chưa tô của file gốc, (chưa tô màu vàng), chạy thử nữa. Vừa ý rồi thì hãy thử trên file gốc.

Phím tắt lần này là Ctr+Q

 

[xda1811]

File đã xong.
Vì lần này đổi dấu * thành số từ 1 đến hết, nên không chạy lại lần 2, lần 3 như tô màu kiểu kia c nữa. Do đó phải sao lưu trước khi chạy.

Có thể làm 1 code để undo nhưng để sau nha. Hoặc nếu muốn thì kết hợp luôn, xóa màu tô cũ, đổi số thành *, tô lại. (Vì chưa biết cụ thể em muốn gì)

Còn bây giờ chịu khó thử trên file copy thôi. Thử 1 lần, copy lại dữ liệu chưa tô của file gốc, (chưa tô màu vàng), chạy thử nữa. Vừa ý rồi thì hãy thử trên file gốc.

Phím tắt lần này là Ctr+Q

anh ơi
em nhấn Ctrt +Q xong. ấn tiếp ctrl + T thì nó mất hết màu vàng
anh làm thế nao mà để em ấn Ctrt +T xong nó vẫn còn màu vàng.
anh thêm cho em đoạn code này với nhé
những ô nào ( 2 ô liên tiếp) dưới đoạn màu xanh và màu tím mà có số thì anh cho nó là màu nâu giúp em
và trong ô bất kỳ nếu 2 ô ( chỉ 2 ô thôi ) có số liên tiếp thì bôi 1 màu
giúp em với nhé
cảm ơn anh nhiều

 

[ptm0412]

1. Đã sửa vụ mất màu vàng khi tô 3 màu ctrl+T
2. Đã sửa code tô màu vàng: trước khi tô vàng, xóa màu vàng, trả các số thứ tự về *, rồi mới tô và đánh số lại.
3. Có thể phục hồi màu vàng thành không màu, số TT thành * nếu chạy riêng code UndoTwo, phím tắt là Ctr + w

 

[ptm0412]

File đã xong vụ tô màu 2 số liên tiếp
phím tắt là Ctrl + e, phục hồi là Ctrl + r

THử cho kỹ rồi hãy xài vô file thực nha, anh test sơ bộ rồi nhưng chỉ test với dữ liệu mẫu.

 

[ptm0412]

Có lỗi tô đè luôn ô màu vàng và màu đỏ nếu các ô này nằm giữa nhóm ô liên tiếp có số liệu. Tải lại file dưới đây

 

[xda1811]

Có lỗi tô luôn màu vàng và màu đỏ nếu các ô này nằm giữa nhóm ô liên tiếp có số liệu. Tải lại file dưới đây

vâng. em cũng đang định nhờ anh sửa hộ lỗi ấy

cảm ơn anh PTM nhiều lắm
chúc anh vui vẻ

 

[xda1811]

anh chỉnh thêm giúp em 1 chút
View attachment anh my.xls

sau ô màu nâu thì có đếm ngày cụ thể ở phía dưới

 

[ptm0412]

Xem file, code trong module "Count", phím tắt là Ctrl + Shift + Y

Chính xác là đếm ô có dấu * sau nhóm ô có màu tím than đầu tiên, cho đến khi gặp ô có số, đếm tiếp 1 lần nữa các ô có dấu *, gặp ô có số thì ngưng, qua cột kế.

Kết quả đếm cho vào sheet "Count" trên cột cùng tên.

 

[xda1811]

Xem file, code trong module "Count", phím tắt là Ctrl + Shift + Y

Chính xác là đếm ô có dấu * sau nhóm ô có màu tím than đầu tiên, cho đến khi gặp ô có số, đếm tiếp 1 lần nữa các ô có dấu *, gặp ô có số thì ngưng, qua cột kế.

Kết quả đếm cho vào sheet "Count" trên cột cùng tên.

anh ơi!
1. tai sheet count B1 đếm liên tiếp dùm em, nó như là phép thống kê ấy.
VD D7,D8 = tím than => count có B1 = 9. tiếp theo B2 =2
2. tiếp tục tại D59,D60 = tím than => count có B1 = 5, tiếp theo B2 = 5
3. tiếp tục tại D94,D95 = tím than => count có B1 = 9, tiếp theo B2 = 6
các cột khác đếm tương tự như cột D anh ạ
cứ thế liên tiếp đến D(n-2)D(n-1) ta sẽ có B1 = ..., b2 =..,

anh chỉnh dùm em với nha

 

[ptm0412]

Sao hôm qua bảo chỉ 2 bước thôi?