Sử dụng VBA tô màu theo điều kiện (1 người xem)

[qvtbvn8]

Em có bài toán sau: tô màu theo điều kiện
b1: xác định các ô kề nhau có giá trị bất kỳ.
b2: tô màu tùy theo điều kiện yêu cầu( đk tùy ý người sử dụng)
Như ví dụ có thể 2 ô liên tiếp.(hoặc có thể 3 ô liên tiếp, hoặc có thể 4 ô liên tiếp,..)
em có file ví dụ nhờ mọi người coi giúp. Và cho em câu trả lời.

 

[qvtbvn8]

nhờ các bác xem dùm code cho bài toán này. xin chân thành cảm ơn!

 

[Ba Tê]

Em có bài toán sau: tô màu theo điều kiện
b1: xác định các ô kề nhau có giá trị bất kỳ.
b2: tô màu tùy theo điều kiện yêu cầu( đk tùy ý người sử dụng)
Như ví dụ có thể 2 ô liên tiếp.(hoặc có thể 3 ô liên tiếp, hoặc có thể 4 ô liên tiếp,..)
em có file ví dụ nhờ mọi người coi giúp. Và cho em câu trả lời.

Nhập 1 con số vào ô Z1. Chạy sub này (có thể cho nó trong sự kiện nào đó)

Public Sub GPE()
Dim Rng As Range, I As Long, J As Long, Num As Long, Dem As Long
Set Rng = Range("B2:S12"): Rng.Interior.ColorIndex = 0
Num = Range("Z1").Value
On Error Resume Next
For I = 1 To Rng.Rows.Count
    Dem = 0
    For J = 1 To Rng.Columns.Count
        If Rng(I, J) <> "" Then
            Dem = Dem + 1
        Else
            If Dem = Num Then
                Rng(I, J - Num).Resize(, Num).Interior.ColorIndex = 36
            End If
            Dem = 0
        End If
    Next J
Next I
End Sub

 

[qvtbvn8]

Nhập 1 con số vào ô Z1. Chạy sub này (có thể cho nó trong sự kiện nào đó)

Public Sub GPE()
Dim Rng As Range, I As Long, J As Long, Num As Long, Dem As Long
Set Rng = Range("B2:S12"): Rng.Interior.ColorIndex = 0
Num = Range("Z1").Value
On Error Resume Next
For I = 1 To Rng.Rows.Count
    Dem = 0
    For J = 1 To Rng.Columns.Count
        If Rng(I, J) <> "" Then
            Dem = Dem + 1
        Else
            If Dem = Num Then
                Rng(I, J - Num).Resize(, Num).Interior.ColorIndex = 36
            End If
            Dem = 0
        End If
    Next J
Next I
End Sub

Em chạy thử rồi thầy ơi nỏ được. thầy coi lại giúp em. Cảm ơn thầy.

 

[Ba Tê]

Em chạy thử rồi thầy ơi nỏ được. thầy coi lại giúp em. Cảm ơn thầy.

"nỏ" là sao", là không được?
Bạn xem file.

 

[qvtbvn8]

"nỏ" là sao", là không được?
Bạn xem file.

Chuẩn bác ơi. do máy để chế độ off macro nên không chạy đc.
Cũng là bài toán ấy, thầy cho em code có yêu cầu chạy 2, 3,4, 5, 6,7,8 các ô kề nhau với số màu lần lượt cho các ô 2,3,4,5,6,7,8 liên tiếp khác nhau theo quy định( từ 1 đến 56 màu).
Cảm ơn bác cùng GPE.

 

[VetMini]

Bài tập thì bạn phải tự làm, chỗ nào bí thì nhờ người ta chỉ dẫn. Sao lại nhờ code từ a đến z vậy?

Mà ông thầy nào dạy cũng ác ôn. Dạy code mà không chịu dạy thuật toán, chỉ lo bày vẽ mấy cái màu mè.
(bạn Phi có ghé qua thì cho hỏi nhỏ: mốt bây giờ chương trình dạy có vậy hôn?)

 

[Ba Tê]

Chuẩn bác ơi. do máy để chế độ off macro nên không chạy đc.
Cũng là bài toán ấy, thầy cho em code có yêu cầu chạy 2, 3,4, 5, 6,7,8 các ô kề nhau với số màu lần lượt cho các ô 2,3,4,5,6,7,8 liên tiếp khác nhau theo quy định( từ 1 đến 56 màu).
Cảm ơn bác cùng GPE.

Thay cái cũ bằng cái này, đọc yêu cầu cũng chưa hiểu lắm.
Chắc không còn yêu cầu nào nữa?

Public Sub GPE()
Dim Rng As Range, I As Long, J As Long, Num As Long, Dem As Long
Set Rng = Range("B2:T12") '<-----------Chọn dư thêm 1 cột trống bên phải'
Rng.Interior.ColorIndex = 0
Num = Range("Z1").Value
For I = 1 To Rng.Rows.Count
    Dem = 0
    For J = 1 To Rng.Columns.Count
        If Rng(I, J) <> "" Then
            Dem = Dem + 1
        Else
            If Dem = Num Then
                Rng(I, J - Num).Resize(, Num).Interior.ColorIndex = Num + 2
            End If
            Dem = 0
        End If
    Next J
Next I
End Sub

 

[qvtbvn8]

Thay cái cũ bằng cái này, đọc yêu cầu cũng chưa hiểu lắm.
Chắc không còn yêu cầu nào nữa?

Public Sub GPE()
Dim Rng As Range, I As Long, J As Long, Num As Long, Dem As Long
Set Rng = Range("B2:T12") '<-----------Chọn dư thêm 1 cột trống bên phải'
Rng.Interior.ColorIndex = 0
Num = Range("Z1").Value
For I = 1 To Rng.Rows.Count
    Dem = 0
    For J = 1 To Rng.Columns.Count
        If Rng(I, J) <> "" Then
            Dem = Dem + 1
        Else
            If Dem = Num Then
                Rng(I, J - Num).Resize(, Num).Interior.ColorIndex = Num + 2
            End If
            Dem = 0
        End If
    Next J
Next I
End Sub

vâng Thầy
Yêu cầu đó là tất các cùng chạy. 2 ô liên tiếp ứng màu vàng, 3 ô lt ứng màu xanh, 4 ô lt ứng màu cam... (số ô bắt đầu do mình lựa chọn ví như mình chọn từ 3 chạy đến 7 chẳng hạn thì có các màu tương ứng được bôi vào dãy ô liên tiếp như vậy.) tất cả cùng chạy, khong chạy đơn lẻ từng cái 1 thầy à.
Còn các code kia chạy ổn cả. chỉ là e hỏi thêm thầy cho màu lên bảng lung linh hơn chút.
Cảm ơn Thầy!

 

[HieuCD]

vâng Thầy
Yêu cầu đó là tất các cùng chạy. 2 ô liên tiếp ứng màu vàng, 3 ô lt ứng màu xanh, 4 ô lt ứng màu cam... (số ô bắt đầu do mình lựa chọn ví như mình chọn từ 3 chạy đến 7 chẳng hạn thì có các màu tương ứng được bôi vào dãy ô liên tiếp như vậy.) tất cả cùng chạy, khong chạy đơn lẻ từng cái 1 thầy à.
Còn các code kia chạy ổn cả. chỉ là e hỏi thêm thầy cho màu lên bảng lung linh hơn chút.
Cảm ơn Thầy!

thử code

Public Sub GPE()
Dim Rng As Range, i As Long, j As Long, k As Long, jk As Byte
Const MinK = 2  'khai bao so o toi thieu
Set Rng = Range("B2:S12")
Rng.Interior.ColorIndex = 0
For i = 1 To Rng.Rows.Count
  For j = 1 To Rng.Columns.Count - 2
    If Rng(i, j) <> "" And Rng(i, j + 1) <> "" Then
      k = 2
      For jk = j + 2 To Rng.Columns.Count
        If Rng(i, jk) <> "" Then
          k = k + 1
        Else
          If k >= MinK Then Rng(i, j).Resize(, k).Interior.ColorIndex = k + 4
          j = jk:          Exit For
        End If
      Next jk
    End If
  Next j
Next i
End Sub

 

[qvtbvn8]

thử code

Public Sub GPE()
Dim Rng As Range, i As Long, j As Long, k As Long, jk As Byte
Const MinK = 2  'khai bao so o toi thieu
Set Rng = Range("B2:S12")
Rng.Interior.ColorIndex = 0
For i = 1 To Rng.Rows.Count
  For j = 1 To Rng.Columns.Count - 2
    If Rng(i, j) <> "" And Rng(i, j + 1) <> "" Then
      k = 2
      For jk = j + 2 To Rng.Columns.Count
        If Rng(i, jk) <> "" Then
          k = k + 1
        Else
          If k >= MinK Then Rng(i, j).Resize(, k).Interior.ColorIndex = k + 4
          j = jk:          Exit For
        End If
      Next jk
    End If
  Next j
Next i
End Sub

báo lỗi số 6 bác à.

 

[qvtbvn8]

đây bác nè

 

[HieuCD]

báo lỗi số 6 bác à.

không biết số 6???, gởi file lổi lên

 

[Ba Tê]

vâng Thầy
Yêu cầu đó là tất các cùng chạy. 2 ô liên tiếp ứng màu vàng, 3 ô lt ứng màu xanh, 4 ô lt ứng màu cam... (số ô bắt đầu do mình lựa chọn ví như mình chọn từ 3 chạy đến 7 chẳng hạn thì có các màu tương ứng được bôi vào dãy ô liên tiếp như vậy.) tất cả cùng chạy, khong chạy đơn lẻ từng cái 1 thầy à.
Còn các code kia chạy ổn cả. chỉ là e hỏi thêm thầy cho màu lên bảng lung linh hơn chút.
Cảm ơn Thầy!

Thấy bạn khoái "lung linh", xem file này, cho bạn tùy chọn "lung linh luôn".
Bạn "mắc" tô màu nào cho số nào tùy bạn.