首页
学习
活动
专区
圈层
工具
发布
首页
学习
活动
专区
圈层
工具
MCP广场
社区首页 >问答首页 >VBA颜色根据下拉列表值对整个列进行编码

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

Stack Overflow用户
提问于 2017-02-02 14:26:53
回答 3查看 1.2K关注 0票数 1

我在第一页VBA窗口中有代码。工作簿中的excel工作表1与C列中的下拉列表一起使用。下拉列表的4个选项是:完成、挂起、错过截止日期和可行。下拉列表是使用工作表2和定义名称方法生成的。但是,当我选择值(例如“完成”)时,整行的颜色不会变成绿色。我哪里出问题了?

代码语言:javascript
运行
复制
Private Sub Worksheet_Change(ByVal Target As Range)

'to make entire row green when job is workable
If Selection.Text = "Workable" Then
With ActiveCell
Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)).Select
         With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5287936
        .TintAndShade = 0
        .PatternTintAndShade = 0

    End With
    End With

' to make entire row yellow when pending additonal information

ElseIf Selection.Text = "Pending" Then
With ActiveCell
Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)).Select

   With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0

    End With
    End With
'to make entire row red when job is not workable

ElseIf Selection.Text = "Missed Deadline" Then
With ActiveCell
Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)).Select
With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
        .PatternTintAndShade = 0
End With
End With


'to make entire row light blue when job is complete

ElseIf Selection.Text = "Complete" Then
With ActiveCell
Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)).Select
With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0

End With
End With

 MsgBox "AWESOME!YOU DID IT!"

 End If


End Sub

请查看代码,并请帮助。非常感谢!

EN

回答 3

Stack Overflow用户

回答已采纳

发布于 2017-02-02 15:00:26

详细说明上面的评论

代码语言:javascript
运行
复制
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
票数 0
EN

Stack Overflow用户

发布于 2017-02-02 14:41:03

纳贝拉

我建议您切换到条件格式以完成此任务,而不是编写宏。

您可以添加4种样式,每种颜色一种,并选择基于公式的条件,并添加一个公式(假定N是具有状态的列,5是表的第一行,用值替换):

代码语言:javascript
运行
复制
= $N5="Workable"

如果您需要或条件,您可以使用

代码语言:javascript
运行
复制
= (($N5="Workable")+($N5="SomethingElse")>0)

如果你需要和条件,使用

代码语言:javascript
运行
复制
= ($N5="Workable")*($N5="SomethingElse")

然后将样式应用于整个桌子。

考虑到您的评论,请看下面这个部分:

代码语言:javascript
运行
复制
With ActiveCell
    Range(Cells(.[........]

我会把这个换成

代码语言:javascript
运行
复制
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...]
票数 0
EN

Stack Overflow用户

发布于 2017-02-02 16:40:18

试试这个:

代码语言:javascript
运行
复制
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 (白色):

代码语言:javascript
运行
复制
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
票数 0
EN
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接:

https://stackoverflow.com/questions/42004768

复制
相关文章

相似问题

领券
问题归档专栏文章快讯文章归档关键词归档开发者手册归档开发者手册 Section 归档