VBA根据下拉列表值对整列进行颜色编码

3 回答

• 0

  详细说明上述评论

  Private Sub Worksheet_Change(ByVal Target As Range)
  
  'to make entire row green when job is workable
  If Target.Text = "Workable" Then
      With Target.EntireRow
          With .Interior
              .Pattern = xlSolid
              .PatternColorIndex = xlAutomatic
              .Color = 5287936
              .TintAndShade = 0
              .PatternTintAndShade = 0
          End With
      End With
  
      'etc
  

  回复于 2024-05-12T03:02:32+08:00
• 0

  Nabeela，

  我建议您切换到条件格式来完成此任务，而不是编写宏 .

  您可以添加4种样式，每种颜色一种，并选择基于公式的条件，并添加公式（考虑 N is the column with the status and 5 is the 1st row of the table ，替换为您的值）：

  = $N5="Workable"
  

  如果您需要OR条件，您可以使用

  = (($N5="Workable")+($N5="SomethingElse")>0)
  

  如果您需要AND条件，请使用

  = ($N5="Workable")*($N5="SomethingElse")
  

  然后将样式应用于整个表格 .

  .

  Considering your comment ，看看这部分：

  With ActiveCell
      Range(Cells(.[........]
  

  我会改变这个

  Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng as Excel.Range
  '[...]  - your code here
  With ActiveCell
  Set rng = ActiveSheet.Range( _
      Cells(.Row, .CurrentRegion.Column), _
      Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1))
  With rng.Interior
      .Pattern = xlSolid
      .PatternColorIndex = xlAutomatic
      .Color = 5287936
      .TintAndShade = 0
      .PatternTintAndShade = 0
  End With
  '[...and so on...]
  

  回复于 2024-05-12T03:02:32+08:00
• 0

  试试这个：

  Private Sub Worksheet_Change(ByVal Target As Range)
  
   Dim mClr As Long
   If Target.Column <> 3 Or Target.Count > 1 Then Exit Sub
  
      Select Case Target.Value
          Case "Workable": mClr = 5287936
          Case "Pending": mClr = 65535
          Case "Missed Deadline": mClr = 255
          Case "Complete": mClr = 16247773
          Case Else: Exit Sub
      End Select
  
      With Target.EntireRow.Interior
          .Pattern = xlSolid
          .PatternColorIndex = xlAutomatic
          .Color = mClr
          .TintAndShade = 0
          .PatternTintAndShade = 0
      End With
  End Sub
  

  如果多个单元格同时更改（例如使用复制和粘贴），并且如果单元格值不在列表中，则将颜色重置为 xlNone （白色），以使上面的代码工作：

  Private Sub Worksheet_Change(ByVal Target As Range)
  
   Dim mClr As Long, Rng As Range, Cel As Range
   Set Rng = Application.Intersect(Target, Columns(3))
  
   If Not Rng Is Nothing Then
       For Each Cel In Rng
          Select Case Cel.Value
              Case "Workable": mClr = 5287936
              Case "Pending": mClr = 65535
              Case "Missed Deadline": mClr = 255
              Case "Complete": mClr = 16247773
              Case Else: mClr = xlNone
          End Select
  
          With Cel.EntireRow.Interior
              .Pattern = xlSolid
              .PatternColorIndex = xlAutomatic
              .Color = mClr
              .TintAndShade = 0
              .PatternTintAndShade = 0
          End With
       Next
   End If
  End Sub
  

  回复于 2024-05-12T03:02:32+08:00