How do I combine these 4 Private Sub Worksheet Changes in Excel 2010?

S

Spartan920

New Member
Joined
Sep 14, 2012
Messages
9
I need help combining these 4 Private Sub Worksheet Changes:

Private Sub Worksheet_Change(ByVal Target As Range)<o:p></o:p>
IfTarget.Address(0, 0) = "A1" Then<o:p></o:p>
WithSheets("Dashboard").Shapes("Oval 1").Fill.ForeColor<o:p></o:p>
SelectCase UCase(Target.Value)<o:p></o:p>
Case"RED": .RGB = vbRed<o:p></o:p>
Case "YELLOW": .RGB = RGB(255, 255,109)<o:p></o:p>
Case"GREEN": .RGB = RGB(41, 247, 46)<o:p></o:p>
Case"GREY": .RGB = RGB(127, 127, 127)<o:p></o:p>
End Select<o:p></o:p>
End With<o:p></o:p>
End If<o:p></o:p>
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)<o:p></o:p>
IfTarget.Address(0, 0) = "B12" Then<o:p></o:p>
WithSheets("Dashboard").Shapes("Rectangle 111").Fill.ForeColor<o:p></o:p>
SelectCase UCase(Target.Value)<o:p></o:p>
Case"RED": .RGB = vbRed<o:p></o:p>
Case "YELLOW": .RGB = RGB(255, 255,109)<o:p></o:p>
Case"GREEN": .RGB = RGB(41, 247, 46)<o:p></o:p>
Case"GREY": .RGB = RGB(127, 127, 127)<o:p></o:p>
End Select<o:p></o:p>
End With<o:p></o:p>
End If<o:p></o:p>
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)<o:p></o:p>
IfTarget.Address(0, 0) = "R11" Then<o:p></o:p>
WithSheets("Dashboard").Shapes("Rounded Rectangle 3").Fill.ForeColor<o:p></o:p>
SelectCase UCase(Target.Value)<o:p></o:p>
Case"RED": .RGB = vbRed<o:p></o:p>
Case "YELLOW": .RGB = RGB(255, 255,109)<o:p></o:p>
Case"GREEN": .RGB = RGB(41, 247, 46)<o:p></o:p>
Case"GREY": .RGB = RGB(127, 127, 127)<o:p></o:p>
End Select<o:p></o:p>
End With<o:p></o:p>
End If<o:p></o:p>
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)<o:p></o:p>
IfTarget.Address(0, 0) = "P24" Then<o:p></o:p>
WithSheets("Dashboard").Shapes("Isosceles Triangle 2").Fill.ForeColor<o:p></o:p>
SelectCase UCase(Target.Value)<o:p></o:p>
Case"RED": .RGB = vbRed<o:p></o:p>
Case "YELLOW": .RGB = RGB(255, 255,109)<o:p></o:p>
Case"GREEN": .RGB = RGB(41, 247, 46)<o:p></o:p>
Case"GREY": .RGB = RGB(127, 127, 127)<o:p></o:p>
End Select<o:p></o:p>
End With<o:p></o:p>
End If<o:p></o:p>
End Sub

Any help would be most appreciated!
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Sort by date Sort by votes
try:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1,B12,R11,P24")) Is Nothing Then
Select Case Target.Address(0, 0)
    Case "A1"
        myShape = "Oval 1"
    Case "B12"
        myShape = "Rectangle 111"
    Case "R11"
        myShape = "Rounded Rectangle 3"
    Case "P24"
        myShape = "Isosceles Triangle 2"
End Select
With Sheets("Dashboard").Shapes(myShape).Fill.ForeColor
    Select Case UCase(Target.Value)
        Case "RED": .RGB = vbRed
        Case "YELLOW": .RGB = RGB(255, 255, 109)
        Case "GREEN": .RGB = RGB(41, 247, 46)
        Case "GREY": .RGB = RGB(127, 127, 127)
    End Select
End With
End If
End Sub
 
Last edited:
Upvote 0
One way:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim shp         As Shape
    With Worksheets("Dashboard")
        Select Case Target.Address(False, False)
            Case "A1"
                Set shp = .Shapes("Oval 1")
            Case "B12"
                Set shp = .Shapes("Rectangle 111")
            Case "R11"
                Set shp = .Shapes("Rounded Rectangle 3")
            Case "P24"
                Set shp = .Shapes("Isosceles Triangle 2")
        End Select
    End With
    
    If Not shp Is Nothing Then
        Select Case LCase(Target.Value)
            Case "red"
                shp.Fill.ForeColor.RGB = vbRed
            Case "yellow"
                shp.Fill.ForeColor.RGB = RGB(255, 255, 109)
            Case "green"
                shp.Fill.ForeColor.RGB = RGB(41, 247, 46)
            Case "grey"
                shp.Fill.ForeColor.RGB = RGB(127, 127, 127)
        End Select
    End If
End Sub
 
Upvote 0
try (untested):
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Application.Intersect(Target, Range("A1"), Range("B12"), Range("R11"), Range("P24")) Is Nothing Then
        Select Case Target.Address(0, 0)
            Case "A1": sShapeName = "Oval 1"
            Case "B12": sShapeName = "Rectangle 111"
            Case "R11": sShapeName = "Rounded Rectangle 3"
            Case "P24": sShapeName = "Isosceles Triangle 2"
        End Select
        WithSheets("Dashboard").Shapes(sShapeName).Fill.ForeColor
            Select Case UCase(Target.Value)
                Case "RED": .RGB = vbRed
                Case "YELLOW": .RGB = RGB(255, 255, 109)
                Case "GREEN": .RGB = RGB(41, 247, 46)
                Case "GREY": .RGB = RGB(127, 127, 127)
            End Select
        End With
    End If
End Sub
 
Last edited:
Upvote 0
following on from my previous post, this version would cater for multiple cells being changed at once (say by copying and pasting a block of data or pressing Ctrl+Enter when several cells are selected) and they include one or more of your target cells:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim SomeCells As Range
Set SomeCells = Intersect(Target, Range("A1,B12,R11,P24"))
If Not SomeCells Is Nothing Then
    For Each cll In SomeCells.Cells
        Select Case cll.Address(0, 0)
            Case "A1":  myShape = "Oval 1"
            Case "B12": myShape = "Rectangle 111"
            Case "R11": myShape = "Rounded Rectangle 3"
            Case "P24": myShape = "Isosceles Triangle 2"
        End Select
        With Sheets("Dashboard").Shapes(myShape).Fill.ForeColor
            Select Case UCase(cll.Value)
                Case "RED": .RGB = vbRed
                Case "YELLOW": .RGB = RGB(255, 255, 109)
                Case "GREEN": .RGB = RGB(41, 247, 46)
                Case "GREY": .RGB = RGB(127, 127, 127)
            End Select
        End With
    Next cll
End If
End Sub
 
Last edited:
Upvote 0
I haven't reviewed any of the other posts so the below may or may not duplicate one or more of the suggestions.

Performing multiple tasks in an event procedure
Multiple event tasks


Spartan920 said:
I need help combining these 4 Private Sub Worksheet Changes:

Private Sub Worksheet_Change(ByVal Target As Range)<o:p></o:p>
IfTarget.Address(0, 0) = "A1" Then<o:p></o:p>
WithSheets("Dashboard").Shapes("Oval 1").Fill.ForeColor<o:p></o:p>
SelectCase UCase(Target.Value)<o:p></o:p>
Case"RED": .RGB = vbRed<o:p></o:p>
Case "YELLOW": .RGB = RGB(255, 255,109)<o:p></o:p>
Case"GREEN": .RGB = RGB(41, 247, 46)<o:p></o:p>
Case"GREY": .RGB = RGB(127, 127, 127)<o:p></o:p>
End Select<o:p></o:p>
End With<o:p></o:p>
End If<o:p></o:p>
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)<o:p></o:p>
IfTarget.Address(0, 0) = "B12" Then<o:p></o:p>
WithSheets("Dashboard").Shapes("Rectangle 111").Fill.ForeColor<o:p></o:p>
SelectCase UCase(Target.Value)<o:p></o:p>
Case"RED": .RGB = vbRed<o:p></o:p>
Case "YELLOW": .RGB = RGB(255, 255,109)<o:p></o:p>
Case"GREEN": .RGB = RGB(41, 247, 46)<o:p></o:p>
Case"GREY": .RGB = RGB(127, 127, 127)<o:p></o:p>
End Select<o:p></o:p>
End With<o:p></o:p>
End If<o:p></o:p>
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)<o:p></o:p>
IfTarget.Address(0, 0) = "R11" Then<o:p></o:p>
WithSheets("Dashboard").Shapes("Rounded Rectangle 3").Fill.ForeColor<o:p></o:p>
SelectCase UCase(Target.Value)<o:p></o:p>
Case"RED": .RGB = vbRed<o:p></o:p>
Case "YELLOW": .RGB = RGB(255, 255,109)<o:p></o:p>
Case"GREEN": .RGB = RGB(41, 247, 46)<o:p></o:p>
Case"GREY": .RGB = RGB(127, 127, 127)<o:p></o:p>
End Select<o:p></o:p>
End With<o:p></o:p>
End If<o:p></o:p>
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)<o:p></o:p>
IfTarget.Address(0, 0) = "P24" Then<o:p></o:p>
WithSheets("Dashboard").Shapes("Isosceles Triangle 2").Fill.ForeColor<o:p></o:p>
SelectCase UCase(Target.Value)<o:p></o:p>
Case"RED": .RGB = vbRed<o:p></o:p>
Case "YELLOW": .RGB = RGB(255, 255,109)<o:p></o:p>
Case"GREEN": .RGB = RGB(41, 247, 46)<o:p></o:p>
Case"GREY": .RGB = RGB(127, 127, 127)<o:p></o:p>
End Select<o:p></o:p>
End With<o:p></o:p>
End If<o:p></o:p>
End Sub

Any help would be most appreciated!
Click to expand...
 
Upvote 0
Thanks to everyone for helping me out. I tried p45cal's first and it did the trick.

p45cal, your other post about copying and pasting a block of data was going to be my next question, haha. Much appreciated.

Thanks again.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Prevent worksheet change from triggering when similar macro is executed?
Replies
1
Views
278
AlphaFrog
AlphaFrog
T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
432
tixarah
T
A
  • Question Question
I can't get private sub to run to update sheet name when the value in Cell A1 has changed
Replies
1
Views
541
duggie33
D
P
  • Question Question
How do I combine two codes into one ?
Replies
1
Views
459
OaklandJim
O
S
  • Solved
Automate tab color changes for the whole workbook based on a cell in each sheet
Replies
3
Views
965
kevin9999
K

Forum statistics

Threads
1,226,693
Messages
6,192,460
Members
453,725
Latest member
cvsdatreas

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top