Set màu cho chữ trong Excel

[cang95166]

Chào các bạn,
Xin cho hỏi có cách nào set cho chữ có màu như mình mong muốn trong một dãy chữ không các bạn:
~vd:trong một ô excel có một hàng chữ
AAACCCDDDFFFEEEOO
=>mình làm sao để thành
AAACCCDDDFFFEEEOO
(có nhiều hàng & các chữ khác nhau)

~vd:
SSSAADDDRRFFYY =>SSSAADDDRRFFYY
OOOJJDDDRRFF =>OOOJJDDDRRFF
VVVXXJJFFUUBB =>VVVXXJJFFUUBB
XXFFGGVVJJRRNN =>XXFFGGVVJJRRNN

Thanks các bạn nhiều

 

[ndu96081631]

Chào các bạn,
Xin cho hỏi có cách nào set cho chữ có màu như mình mong muốn trong một dãy chữ không các bạn:
~vd:trong một ô excel có một hàng chữ
AAACCCDDDFFFEEEOO
=>mình làm sao để thành
AAACCCDDDFFFEEEOO
(có nhiều hàng & các chữ khác nhau)

~vd:
SSSAADDDRRFFYY =>SSSAADDDRRFFYY
OOOJJDDDRRFF =>OOOJJDDDRRFF
VVVXXJJFFUUBB =>VVVXXJJFFUUBB
XXFFGGVVJJRRNN =>XXFFGGVVJJRRNN

Thanks các bạn nhiều

Đương nhiên là làm được... nhưng ít ra bạn cũng phải trình bày cho mọi người rõ về quy luật tô màu chứ
Cách ngon nhất là bạn record macro quá trình bạn tô bằng tay rồi vào xem code, tự nhiên sẽ hiểu liền

 

[hocnuama]

anh giúp em làm file này với cũng liên quan đến tô màu
cám ơn ạ

 

[ndu96081631]

anh giúp em làm file này với cũng liên quan đến tô màu
cám ơn ạ

Thử tạm code này xem:

Sub Tomau()
  Dim Clls As Range, i As Long, k As Long
  On Error GoTo Thoat
  For Each Clls In Application.InputBox("Chon vung", Type:=8)
    k = 0
    Clls.Font.ColorIndex = 0
    If InStr(Clls, "-") Then
      For i = 1 To Len(Clls)
        If Mid(Clls, i, 1) = "-" Then
          k = k + 1: i = i + 1
        End If
        Clls.Characters(i, 1).Font.ColorIndex = Choose((k Mod 5) + 1, 5, 50, 9, 0, 3)
      Next i
    End If
  Next Clls
Thoat:
End Sub

- Mở file đính kèm và bấm nút Chạy code
- Một InputBox xuất hiện, hãy chọn vùng dử liệu và bấm OK

 

[cang95166]

Cám ơn các bạn đã nhiệt tình chỉ dẫn,tuy nhiên file của mình không có dấu "-" giữa các chữ cái mà là khoảng trắng,vậy mình phải sửa lại code thế nào hả các bạn
Thanks các bạn

 

[khoavu87]

thì code của bác Ndu sửa lại mỗi thế này là ok nè.
Option Explicit
Sub Tomau()
Dim Clls As Range, i As Long, k As Long
On Error GoTo Thoat
For Each Clls In Application.InputBox("Chon vung", Type:=8)
k = 0
Clls.Font.ColorIndex = 0
If InStr(Clls, " ") Then
For i = 1 To Len(Clls)
If Mid(Clls, i, 1) = " " Then
k = k + 1: i = i + 1
End If
Clls.Characters(i, 1).Font.ColorIndex = Choose((k Mod 5) + 1, 5, 50, 9, 0, 3)
Next i
End If
Next Clls
Thoat:
End Sub

 

[SA_DQ]

To NDU & các bạn:

Cái này xài Do . . . Loop có vẻ sẽ nhanh hơn tẹo; Tuy nhiên dài dòng chút!

Chúc mọi điều tốt lành!

 

[ndu96081631]

Cái này xài Do . . . Loop có vẻ sẽ nhanh hơn tẹo; Tuy nhiên dài dòng chút!

Chúc mọi điều tốt lành!

Vâng em biết... là duyệt qua từng chữ chứ không duyệt qua từng ký tự... Vì thế mà bài trên em có ghi rằng:

Thử tạm code này xem:

Cũng định làm... nhưng mà.. lười quá (không hứng vì cảm thấy không có ứng dụng gì)

 

[hocnuama]

(không hứng vì cảm thấy không có ứng dụng gì)

Dạ có ứng dụng đấy anh àh. Tại anh hỏng biết đó thôi. Cty em cả trăm mã hàng đấy, cụ thể là Bulong, long đền có nhiều kích cỡ, nếu phân biệt màu khác nhau thì sẽ dễ nhìn hơn, không sợ lo chọn sai mã hàng => sai Nhập Xuất Tồn.
Cám ơn anh NDU...

 

[ndu96081631]

Dạ có ứng dụng đấy anh àh. Tại anh hỏng biết đó thôi. Cty em cả trăm mã hàng đấy, cụ thể là Bulong, long đền có nhiều kích cỡ, nếu phân biệt màu khác nhau thì sẽ dễ nhìn hơn, không sợ lo chọn sai mã hàng => sai Nhập Xuất Tồn.
Cám ơn anh NDU...

Nếu bạn cho là hửu ích, tôi cải tiến file này thêm 1 bước như anh HYen17 đã đề cập ở trên: Duyệt từng chữ (chứ không phải từng ký tự) nhằm giảm số lần lập, tăng tốc độ xử lý

Sub ToMau()
  Dim Clls As Range, Item, Pos As Long, k As Long
  For Each Clls In Application.InputBox("Chon vung", Type:=8)
    Clls.Value = WorksheetFunction.Trim(Clls)
    Clls.Font.ColorIndex = 0
    If InStr(Clls, " ") Then
      k = 0:  Pos = 1
      For Each Item In Split(Clls, " ")
        Clls.Characters(Pos, Len(Item)).Font.ColorIndex = Choose((k Mod 5) + 1, 4, 5, 9, 0, 3)
        Pos = Pos + Len(Item) + 1: k = k + 1
      Next Item
    End If
  Next Clls
End Sub

 

[cang95166]

Cải tiến chút xíu sẽ tốt hơn

Chào các bạn,
Nếu như sửa lại một chút thì tốt hơn cho mình.
Sao cho mỗi loại chữ thì chỉ một màu ở các hàng
(cho dù nằm ở vị trí nào đi nữa)
vd:
FDGF 6565 NDU NDU NDU TR TRG 65T
TR TRG 65T FDGF 6565 NDU NDU NDU
Xin xem file gửi kèm

 

[ndu96081631]

Chào các bạn,
Nếu như sửa lại một chút thì tốt hơn cho mình.
Sao cho mỗi loại chữ thì chỉ một màu ở các hàng
(cho dù nằm ở vị trí nào đi nữa)
vd:
FDGF 6565 NDU NDU NDU TR TRG 65T
TR TRG 65T FDGF 6565 NDU NDU NDU
Xin xem file gửi kèm

Thế thì khó hơn rất nhiều đấy... May mắn nhờ sự hổ trợ của Dictionary Object, mọi chuyện lại được giải quyết.. gọn!

Private Dic
Sub ToMau()
  Dim Clls As Range, Item, Pos As Long, k As Long
  On Error GoTo Thoat
  Set Dic = CreateObject("Scripting.Dictionary")
  With Application.InputBox("Chon vung", Type:=8)
    Dic.RemoveAll
    StrUnique .Cells, " "
    For Each Clls In .Cells
      Clls.Value = WorksheetFunction.Trim(Clls)
      Clls.Font.ColorIndex = 0
      If InStr(Clls, " ") Then
        k = 0:  Pos = 1
        For Each Item In Split(Clls, " ")
          Clls.Characters(Pos, Len(Item)).Font.ColorIndex = (Dic.Item(Item) Mod 37) + 20
          Pos = Pos + Len(Item) + 1: k = k + 1
        Next Item
      End If
    Next Clls
  End With
  Set Dic = Nothing
Thoat:
End Sub

Private Sub StrUnique(TextVal As Range, Optional Sep As String = " ")
  Dim Item, Clls As Range, i As Long
  For Each Clls In TextVal
    If Clls <> "" Then
      For Each Item In Split(Clls.Value, Sep)
        If Not Dic.Exists(Item) Then
          Dic.Add Item, i: i = i + 1
        End If
      Next Item
    End If
  Next Clls
End Sub

Xem file
Bạn có thế thay đổi số 37 và 20 trong đoạn (Dic.Item(Item) Mod 37) + 20 để cho ra màu như ý (thí nghiệm nhé)
Sở dỉ phải làm thế là vì có 1 số màu quá nhạt, không nhìn thấy rõ