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

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
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

T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
306
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
507
duggie33
D
P
  • Question Question
How do I combine two codes into one ?
Replies
1
Views
424
OaklandJim
O
S
  • Solved
Automate tab color changes for the whole workbook based on a cell in each sheet
Replies
3
Views
945
kevin9999
K
WildBurrow
  • Solved
Worksheet Change ByVal Target As Range triggers once then stops
Replies
2
Views
3K
WildBurrow
WildBurrow

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

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