làm sao các ký tự trong cùng một cột giống nhau thì cùng một màu?

[ST-Lu!]

Trong một cột (cột C) các ký tự giống nhau cùng một màu (font colour) thì mình viết code như nào ạh

Em chỉ hình dung nó như sau

Sub fillcolour()
 er as long
Er = [C65000].End(xlUp).row


For i = 1 to Er
    If Cells(i, 3) = cells(i-1,3) then
        '..................... doan nay minh viet nhu nao
    End If
Next
End Sub

 

[ndu96081631]

Trong một cột (cột C) các ký tự giống nhau cùng một màu (font colour) thì mình viết code như nào ạh

Em chỉ hình dung nó như sau

Sub fillcolour()
 er as long
Er = [C65000].End(xlUp).row


For i = 1 to Er
    If Cells(i, 3) = cells(i-1,3) then
        '..................... doan nay minh viet nhu nao
    End If
Next
End Sub

Hỏi lại cho rõ:
- Trong cột C của bạn có bao nhiêu LOẠI khác nhau?
- Cứ khác nhau thì sẽ khác màu à? Vậy nếu có hơn 56 LOẠI khác nhau thì sao tô màu được (vì chỉ có 56 màu)
- Dữ liệu của bạn được sắp xếp trật tự hay lộn xộn?
--------------------
Tóm lại: Vụ này có rất nhiều cách làm (kể cả dùng CF), như ở đây:
http://www.giaiphapexcel.com/forum/showthread.php?t=19200
Nhưng phải tùy yêu cầu cụ thể và dữ liệu cụ thể ---> Bạn đưa file lên xem thử

 

[ST-Lu!]

[C65000].End(xlUp)
1. Số loại <10 thôi
2. Sắp xếp lộn xộn ạh

Nếu công thức liệu có làm được không (đối với excel 2003 & dùng CF)
về code thì em tưởng tượng như này, nhưng em biết vấn sai nè...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo thoat
If Not Intersect(Target, Range("C:C")) Is Nothing Then
    Dim Cell As Range, er As Long
    er = [C65000].End(xlUp).Row
    k = k + 1
    For i = 1 To er
        If target <> "" and Cells(i, 3).Value = cells(i-1,3).value Then
            Cells(i, 3).Font.ColorIndex = k
            Cells(i, 3).Font.ColorIndex = Cells(i - 1, 3).Font.ColorIndex
            
        End If
    Next
   
End If
thoat: Exit Sub
End Sub

hoặc như này

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo thoat
If Not Intersect(Target, Range("C:C")) Is Nothing Then
  If Target <> "" Then
     Select Case Target.Text
     Case "KL"
     Target.Font.ColorIndex = 1
     Case "YML"
     Target.Font.ColorIndex = 2
     Case "?"
     Target.Font.ColorIndex = 3
     
    End Select
    End If
End If
thoat: Exit Sub
End Sub

 

[ndu96081631]

[C65000].End(xlUp)
1. Số loại <10 thôi
2. Sắp xếp lộn xộn ạh

Nếu công thức liệu có làm được không (đối với excel 2003 & dùng CF)
về code thì em tưởng tượng như này, nhưng em biết vấn sai nè...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo thoat
If Not Intersect(Target, Range("C:C")) Is Nothing Then
    Dim Cell As Range, er As Long
    er = [C65000].End(xlUp).Row
    k = k + 1
    For i = 1 To er
        If target <> "" and Cells(i, 3).Value = cells(i-1,3).value Then
            Cells(i, 3).Font.ColorIndex = k
            Cells(i, 3).Font.ColorIndex = Cells(i - 1, 3).Font.ColorIndex
            
        End If
    Next
   
End If
thoat: Exit Sub
End Sub

Đâu có dể ăn thế!
Thử code này xem:

Sub ToMau()
  Dim SrcRng As Range, i As Long, Temp, Clls As Range
  On Error Resume Next
  i = 2
  Set SrcRng = Application.InputBox("Chon vung du lieu", Type:=8)
  With CreateObject("Scripting.Dictionary")
    For Each Clls In SrcRng
      If Not .Exist(Clls.Value) And Clls <> "" Then
        i = i + 1
        .Add Clls.Value, i
      End If
    Next
    For Each Clls In SrcRng
      Clls.Interior.ColorIndex = .Item(Clls.Value)
    Next
  End With
End Sub

Lưu ý:
- Nếu vùng dữ liệu có thể xác định trước thì thay InputBox bằng vùng dữ liệu
- Trong code, giá trị i bắt đầu = 2 ---> Có thể tăng giảm để thử nghiệm

 

[ndu96081631]

Sorry, nhầm 1 chút
Sửa:
If Not .Exist(Clls.Value)
Thành:
If Not .Exists(Clls.Value)
Ngoài ra, có lẽ nên tách sub trên thành 2 sub riêng biệt, 1 cái dùng GetUnique và 1 sub chính để tô màu
Như vầy đây:

Private Dic
Private Sub GetUnique(SrcRng As Range)
  Dim Clls As Range, i As Long
  On Error Resume Next
  i = 2
  Set Dic = CreateObject("Scripting.Dictionary")
  For Each Clls In SrcRng
    If Not Dic.Exists(Clls.Value) And Clls <> "" Then
      i = i + 1
      Dic.Add Clls.Value, i
    End If
  Next
End Sub

Sub ToMau()
  Dim Clls As Range
  On Error Resume Next
  Dic.RemoveAll
  With Application.InputBox("Chon vung du lieu", Type:=8)
    GetUnique .Cells
    For Each Clls In .Cells
      Clls.Font.ColorIndex = Dic.Item(Clls.Value)
    Next
  End With
End Sub

Làm như vậy thì sub GetUnique có thể dùng vào việc khác nữa

 

[ST-Lu!]

Code của Thầy hay quá, thực ra em cũng chưa hiểu lắm
Em thấy thầy rất hay sử dụng chiêu CreateObject
Thầy bật mí cho em thêm một tí về cái này với

 

[ndu96081631]

Code của Thầy hay quá, thực ra em cũng chưa hiểu lắm
Em thấy thầy rất hay sử dụng chiêu CreateObject
Thầy bật mí cho em thêm một tí về cái này với

Thật ra CreateObject("Scripting.Dictionary") là viết cho gọn (khỏi Add Reference)
Đúng ra quy trình phải như vầy:
- Vì Dictionary Object thuộc nhóm Microsoft Scripting Runtime nên đầu tiên bạn vào menu Tools\References và check vào mục Microsoft Scripting Runtime
- Tiếp theo là khai báo biến... chẳng hạn:

Dim Dic As New Dictionary
​

- Với biến này + việc Add References như trên, bạn sẽ được gợi ý về các phương thức và thuộc tính sau dấu chấm ---> Tức bắt đầu từ bây giờ, chỉ cần gõ chữ Dic rồi đến dấu chấm thì lập tức bạn sẽ nhìn thấy 1 tooltip xổ xuống gợi ý về các phương thức và thuộc tính của Object này
- Muốn biết từng phương thức và thuộc tính có tác dụng gì thì đơn giản chỉ cần bôi đen và F1
- Ngoài ra cũng có thể tra cứu với Google (tôi thường dùng cách này nhất)

 

[ndu96081631]

Code ở bài trên phải thông qua 2 vòng lập ----> Giờ tôi cải tiến lại, chỉ 1 vòng lập là có thể tô màu ---> Như vậy tốc độ sẽ tăng gấp đôi

Sub ToMau()
  Dim Clls As Range, i As Long
  On Error Resume Next
  i = 2
  With CreateObject("Scripting.Dictionary")
    For Each Clls In Application.InputBox("Chon vung du lieu", Type:=8)
      If Clls <> "" Then
        If Not .Exists(Clls.Value) Then
          i = i + 1: .Add Clls.Value, ((i - 1) Mod 56) + 1
          Clls.Font.ColorIndex = ((i - 1) Mod 56) + 1
        Else
          Clls.Font.ColorIndex = .Item(Clls.Value)
        End If
      End If
    Next
  End With
End Sub

 

[Tường_Vi]

Thật ra CreateObject("Scripting.Dictionary") là viết cho gọn (khỏi Add Reference)
Đúng ra quy trình phải như vầy:
- Vì Dictionary Object thuộc nhóm Microsoft Scripting Runtime nên đầu tiên bạn vào menu Tools\References và check vào mục Microsoft Scripting Runtime
- Tiếp theo là khai báo biến... chẳng hạn: Dim Dic As New Dictionary

Bác NDu ơi, cho TV hỏi chút, TV đã làm theo hướng dẫn ở trên nhưng không tài nào đánh dấu chấm xong thấy gợi ý cả

Nhưng ví dụ khi TV khai Dim Dic as Dictionary, sau câu này TV Dic. một cái là có hàng loạt danh sách down xuống

 

[ndu96081631]

Bác NDu ơi, cho TV hỏi chút, TV đã làm theo hướng dẫn ở trên nhưng không tài nào đánh dấu chấm xong thấy gợi ý cả

Nhưng ví dụ khi TV khai Dim Dic as Dictionary, sau câu này TV Dic. một cái là có hàng loạt danh sách down xuống

Tôi chưa hiểu lắm ý bạn... Tóm lại bạn không nhận được những gợi ý từ cái Tooltip xổ xuống hay là sao?

 

[Tường_Vi]

[quote = NDU]
Tóm lại bạn không nhận được những gợi ý từ cái Tooltip xổ xuống hay là sao?
[/quote]
Dạ vâng, nghĩa là sau khi em đã làm theo hướng dẫn tíc vào menu Tools\References và check vào mục Microsoft Scripting Runtime
nhưng ví dụ đoạn code sau tại sao em gõ If not . nhưng không thấy có gì xổ xuống nhỉ?

Nhân tiện em hỏi thêm đoạn code sau
1. If clls <> "" --> nghĩa là cell đó khác rỗng rồi nhưng phía dưới lại if not .exist (clls.value) là sao
vì theo em hiểu exist nghĩa là tồn tại

Đoạn code này cao quá em không hiểu được NDU ạh

      If Clls <> "" Then
        If Not .Exists(Clls.Value) Then
          i = i + 1: .Add Clls.Value, ((i - 1) Mod 56) + 1
          Clls.Font.ColorIndex = ((i - 1) Mod 56) + 1
        Else
          Clls.Font.ColorIndex = .Item(Clls.Value)

Dạ vâng
</span></span>

 

[ndu96081631]

Dạ vâng, nghĩa là sau khi em đã làm theo hướng dẫn tíc vào menu Tools\References và check vào mục Microsoft Scripting Runtime
nhưng ví dụ đoạn code sau tại sao em gõ If not . nhưng không thấy có gì xổ xuống nhỉ?

Từ nhiên chấm không không thế thì xổ cái gì xuống đây?
Ít ra thì cũng

Dim Dic As New Dictionary
Dic.

Hoặc

With New Dictionary
  .  '<--- (chấm không không là do có With ở trên)
End With

Nhân tiện em hỏi thêm đoạn code sau
1. If clls <> "" --> nghĩa là cell đó khác rỗng rồi nhưng phía dưới lại if not .exist (clls.value) là sao
vì theo em hiểu exist nghĩa là tồn tại

Đoạn code này cao quá em không hiểu được NDU ạh

      If Clls <> "" Then
        If Not .Exists(Clls.Value) Then
          i = i + 1: .Add Clls.Value, ((i - 1) Mod 56) + 1
          Clls.Font.ColorIndex = ((i - 1) Mod 56) + 1
        Else
          Clls.Font.ColorIndex = .Item(Clls.Value)

- Trước tiên bạn lưu ý rằng: Cái gì người ta đanh dấu chấm không không thì phía trên nó phải có 1 cái With ---> Tức sau dấu chấm là 1 bộ phận thuộc With ở trên... Được chưa?
(tôi thường làm vậy để khỏi khai báo biến, ngoài ra còn những mặc lợi khác nữa...)
- Tại sao phải cần có if not .exist (clls.value)? Vì mỗi khi ta Add giá trị vào Keys thì phải kiểm tra xem giá trị ấy có tồn tại hay chưa? Nếu giá trị ấy có rồi mà ta vẫn "cố tình" Add thêm thì nó sẽ.. cằn nhằn ---> Đây cũng chính là tính chất người ta tận dụng để lấy Unique List (vì biết chắc sẽ chẳng bao giờ có 2 giá trị trùng nhau trong Keys)
-----------------------
Xin lỗi vì tôi kém mấy vụ giải thích lắm, hy vọng bạn cố gắng hiểu ---> Cái này nói khó cũng không khó... Hiểu được sẽ thấy.. dễ hơn ăn cháo
Ẹc... Ẹc..