Nhờ các bạn giúp tô màu theo điều kiện VBA

[Trần Văn Bình]

Hiện mình dùng dùng Conditinonal Formatting với hàm Vlookup thì bôi được
nhưng dùng Code thì chạy không được. Nhờ các bạn giúp với có file đính kèm
Hàm điều kiện của 1 cột Conditinonal Formatting mình để tại Cột L
Các bạn giúp mình viết lại Code giúp
Xin chân thành cám ơn!

 

[Trần Văn Bình]

Mình có viết lại Code mà sao không tô được màu. Nhờ anh em giúp với
Sub To_Mau()
Dim sArr(), Arr_Time(), i As Long
Dim j As Long, Lr As Long, k As Long
Lr = Sheet12.Range("J" & Rows.Count).End(xlUp).Row
Arr_Time() = Sheet9.Range("B6:F22").Value

With Sheet12
sArr = Sheet12.Range("F5:J" & Lr).Value
'ReDim kq(1 To UBound(sArr), 1 To 5)
Sheet12.Range("F5:J" & Lr).Interior.ColorIndex = xlNone
For i = 1 To UBound(sArr)
For j = 1 To UBound(Arr_Time)
For k = 1 To 5

k = k + 1
If sArr(i, 5) = Arr_Time(j, 1) And sArr(i, 1) >= Arr_Time(j, 2) Then
If sArr(i, 5) = Arr_Time(j, 1) And sArr(i, 2) >= Arr_Time(j, 3) Then
If sArr(i, 5) = Arr_Time(j, 1) And sArr(i, 3) >= Arr_Time(j, 4) Then
If sArr(i, 5) = Arr_Time(j, 1) And sArr(i, 4) >= Arr_Time(j, 5) Then
.Cells(i, k).Interior.ColorIndex = 6
'Else
'.Cells(i, k).Interior.ColorIndex = xlNone
End If
End If
End If
End If
Next k
Next j
Next i
'.Range("f5").Resize(i, 4).Value = kq
End With

End Sub

 

[Phuocam]

Hiện mình dùng dùng Conditinonal Formatting với hàm Vlookup thì bôi được
nhưng dùng Code thì chạy không được. Nhờ các bạn giúp với có file đính kèm
Hàm điều kiện của 1 cột Conditinonal Formatting mình để tại Cột L
Các bạn giúp mình viết lại Code giúp
Xin chân thành cám ơn!

Nếu trong bảng Thống kê các cột F4 đến J4 có tiêu đề và vị trí giống bảng trong sheet Data_Time thỉ code dễ dàng hơn.

 

[HieuCD]

Hiện mình dùng dùng Conditinonal Formatting với hàm Vlookup thì bôi được
nhưng dùng Code thì chạy không được. Nhờ các bạn giúp với có file đính kèm
Hàm điều kiện của 1 cột Conditinonal Formatting mình để tại Cột L
Các bạn giúp mình viết lại Code giúp
Xin chân thành cám ơn!

Chạy code . . .

Sub Kq_Color()
  Dim Rng As Range, arr(), hang$, sR&, sR2&, i&, r&, j&
 
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  With Sheets("Data_Time")
    arr = .Range("B6:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
    sR = UBound(arr)
  End With
  With Sheets("Thongke")
    Set Rng = .Range("E5", .Range("J" & Rows.Count).End(xlUp))
  End With
  Rng.Interior.ColorIndex = 0
  sR2 = Rng.Rows.Count
  For i = 1 To sR2
    hang = Rng(i, 6).Value
    For r = 1 To sR
      If arr(r, 1) = hang Then
        For j = 2 To 4
          If arr(r, j) > Rng(i, j) Then Rng(i, j).Interior.ColorIndex = 6
        Next j
        exit for
      End If
    Next r
  Next i
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Set Rng = Nothing
End Sub

 

[snow25]

Hiện mình dùng dùng Conditinonal Formatting với hàm Vlookup thì bôi được
nhưng dùng Code thì chạy không được. Nhờ các bạn giúp với có file đính kèm
Hàm điều kiện của 1 cột Conditinonal Formatting mình để tại Cột L
Các bạn giúp mình viết lại Code giúp
Xin chân thành cám ơn!

Thử code này.

Sub tomau()
    Dim arr, kq, i As Long, lr As Long, dic As Object, a As Long, j As Integer, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Data_time")
         arr = .Range("B6:F22")
         For i = 1 To UBound(arr)
            dk = arr(i, 1)
            dic.Item(dk) = i
         Next i
    End With
    With Sheets("thongke")
         lr = .Range("J" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         .Range("F5:I" & lr).Interior.ColorIndex = 2
         For i = 5 To lr
             a = dic.Item(.Cells(i, 10).Value)
             If a Then
                For j = 6 To 9
                    If arr(a, j - 4) > .Cells(i, j).Value Then
                       .Cells(i, j).Interior.ColorIndex = 6
                    End If
                Next j
             End If
        Next i
   End With
   Set dic = Nothing
End Sub

 

[Trần Văn Bình]

Mình chân thành cảm ơn bạn HieuCD và bạn snow25 giúp mình và đã cho ra kết quả theo mong muốn
Lần nữa cảm ơn 2 bạn rất nhiều

 

[Trần Văn Bình]

Thử code này.

Sub tomau()
    Dim arr, kq, i As Long, lr As Long, dic As Object, a As Long, j As Integer, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Data_time")
         arr = .Range("B6:F22")
         For i = 1 To UBound(arr)
            dk = arr(i, 1)
            dic.Item(dk) = i
         Next i
    End With
    With Sheets("thongke")
         lr = .Range("J" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         .Range("F5:I" & lr).Interior.ColorIndex = 2
         For i = 5 To lr
             a = dic.Item(.Cells(i, 10).Value)
             If a Then
                For j = 6 To 9
                    If arr(a, j - 4) > .Cells(i, j).Value Then
                       .Cells(i, j).Interior.ColorIndex = 6
                    End If
                Next j
             End If
        Next i
   End With
   Set dic = Nothing
End Sub

nhờ bạn dịch CODE cho mình đoạn này với
For i = 5 To lr
a = dic.Item(.Cells(i, 10).Value)
If a Then
For j = 6 To 9
If arr(a, j - 4) > .Cells(i, j).Value Then
.Cells(i, j).Interior.ColorIndex = 6
End If
Next j
End If
Next i
Nguyên nhân mình muốn đổi Cột Hạng đào tạo ra trước