Private Sub Worksheet_Change(ByVal Target As Range) with multiple targets

[TheHighlander]

Hello,

I am still fairly new to VBA programming but have been learning quickly. When looking for a way to add conditional formatting to a shape to make it change color, I came across "Private Sub Worksheet_Change(ByVal Target As Range)." While I was able to get this to work with a single shape and target, I do not know how to make this work with multiple targets.

The code I am trying to use as reference to alter my code is:
---------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("E3") = "COPIED" Then
ActiveSheet.Shapes.Range(Array("Rectangle1")).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(112, 173, 71)

Else
If Range("E3") = "COPY" Then
ActiveSheet.Shapes.Range(Array("Rectangle1")).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(91, 155, 213)
End If
End If
ActiveSheet.Cells(2, 6).Select
End Sub
-----------------------------------------------------------------------------
(toggle BB code does not seem to be working for me)

I can get this to work, but only for 1 button.

What I want to happen:
When you click the "COPY" button, the button changes color and the words change to "COPIED." Clicking it again changes the color back and the word becomes "COPY" again.
I have all the code done except my method of changing color has a fault.

My problem is that I also have macros that sort the Name, Level, Kind, and Number columns. I have included the hidden column "E" (DATA column) in the sort so that the "COPIED" notation
moves with the other data. But I also need the button color to move with the data.
I have only 5 of these on my testing file, but will have 100 of these buttons on my actual file, so am looking for the easiest and most elegant solution to this.
I have included a screenshot as the buttons (shapes) that have macros attached to them do not seem to be showing up in the Mini Sheet picture.

This is my current code for the COPY buttons
----------------------------------------------------------------------------
Sub Copy2()

With ActiveSheet

If Range("E2").Value = "COPY" Or Range("E2") = Empty Then
Range("E2").Value = "COPIED"
ActiveSheet.Shapes("Rectangle 1").Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(112, 173, 71)

Else
Range("E2").Value = "COPY"
ActiveSheet.Shapes("Rectangle 1").Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(91, 155, 213)

End If

Cells(2, 11).Resize(, 4).Value = Cells(2, 1).Resize(, 4).Value

End With
End Sub
--------------------------------------------------------------------------------

Copy Button2.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	Name	Level	Kind	Number	DATA						DATA COPIED
2	Bill	level 7	red	150,000	COPY						Mary	level 10	yellow	310000
3	Bob	level 9	yellow	250,000	COPY
4	Cat	level 8	red	340,000	COPY
5	Kathy	level 10	blue	283,000	COPY
6	Mary	level 10	yellow	310,000	COPY
7	Willy	level 4	yellow	300,000
8
9
10											Name A	#
11											Type A
12											Level A
13											Num A
14
15	SUB
16	Willy	level 4	blue	300000
17
18
19
20
21
22
23
24
25
ALL

 

[Candyman8019]

Try something like this. This will work whenever a cell in range E2:E14 is selected. It can be changed to work with whatever range you need. There is a second section where you can have it run when a cell in a different range is selected. Additional sections can be added as desired.

Private Sub worksheet_selectionchange(ByVal target As Range)
If Not Intersect(target, Range("E2:E14")) Is Nothing Then
    Application.EnableEvents = False
        If target.Value = "COPY" Then
            target.Value = "COPIED"
            target.Cells.Interior.Color = RGB(112, 173, 71)
            target.Offset(0, 1).Select
        Else
            target.Value = "COPY"
            target.Cells.Interior.Color = RGB(91, 155, 213)
            target.Offset(0, 1).Select
    End If
    Cells(2, 11).Resize(, 4).Value = Cells(2, 1).Resize(, 4).Value
    Application.EnableEvents = True
End If

If Not Intersect(target, Range("F2:F14")) Is Nothing Then
    '...do something
End If
End Sub

 

[Candyman8019]

I moved/changed your copy command a bit...

Private Sub worksheet_selectionchange(ByVal target As Range)
If Not Intersect(target, Range("E2:E14")) Is Nothing Then
    Application.EnableEvents = False
        If target.Value = "COPY" Then
            target.Value = "COPIED"
            target.Cells.Interior.Color = RGB(112, 173, 71)
            Cells(2, 11).Resize(, 4).Value = Cells(target.row, 1).Resize(, 4).Value
            target.Offset(0, 1).Select
        Else
            target.Value = "COPY"
            target.Cells.Interior.Color = RGB(91, 155, 213)
            target.Offset(0, 1).Select
    End If
    Application.EnableEvents = True
End If

If Not Intersect(target, Range("F2:F14")) Is Nothing Then
    '...do something
End If
End Sub

 

[TheHighlander]

I moved/changed your copy command a bit...

Private Sub worksheet_selectionchange(ByVal target As Range)
If Not Intersect(target, Range("E2:E14")) Is Nothing Then
    Application.EnableEvents = False
        If target.Value = "COPY" Then
            target.Value = "COPIED"
            target.Cells.Interior.Color = RGB(112, 173, 71)
            Cells(2, 11).Resize(, 4).Value = Cells(target.row, 1).Resize(, 4).Value
            target.Offset(0, 1).Select
        Else
            target.Value = "COPY"
            target.Cells.Interior.Color = RGB(91, 155, 213)
            target.Offset(0, 1).Select
    End If
    Application.EnableEvents = True
End If

If Not Intersect(target, Range("F2:F14")) Is Nothing Then
    '...do something
End If
End Sub

Thank you very much for your kind assistance.
It works a treat when I click on the "E2:E14" cells.

But that column is meant to be hidden, with only the COPY buttons in column F being visible. Those are shapes that are named "rectangle1" to "rectangle5"
This is what I want to happen:

When the user clicks on a COPY button (which is a shape, to make it clear that it is a button),
1. the button changes from blue to green
2. the button's words changes from "COPY" to "COPIED"
3. the data to the left of the button is put in the "DATA COPIED" cells.
4. (I forgot to add in my original question) the row of data copied is highlighted green

When the user clicks on the button again, which now says "COPIED"
1. The button changes from green to blue
2. the button's words changes from "COPIED" to "COPY"
3. (I forgot to add in my original question) the row of data copied reverts to the original color

I have the columns Name, Level, Kind, and Number as buttons as well.
When the user clicks on them, it sorts the data in each column. I have it sort from column A to column E.
If data has been copied, the green highlighted row moves with the sort, as does the "COPIED" text.
My problem is the "COPIED" text moves, but the color does not. So, I am looking for a way to make the colored copy buttons move (or change) with the sort.

I apologize for not being clearer. When I originally wrote my question, I was expecting to be able to upload my sample file for review, like you can do in other forums. By the time I realized I (apparently) can't do that here, I had forgotten to go back and make my intentions more clear.
I put the code you sent me on sheet1 (named ALL).
The code I sent had been a module which I had linked to each corresponding shape.
Is there a way to get this to work with the shapes I have for the COPY buttons?

Or is there a way I can send you the file so you can better understand what I am trying to do?

PS: The thing I forgot in my original question: I would also like to change the line of the data that is copied.
I had been using this code (in each copy button module):

--COPY button 1-- Range("A2:D2").Interior.Color = RGB(112, 173, 71)
--COPY button 2-- Range("A3:D3").Interior.Color = RGB(112, 173, 71)
--COPY button 3-- Range("A4:D4").Interior.Color = RGB(112, 173, 71)
--COPY button 4-- Range("A5:D5").Interior.Color = RGB(112, 173, 71)
--COPY button 5-- Range("A6:D6").Interior.Color = RGB(112, 173, 71)

but I know it can be better done using offset...

Would you be willing to show me how to do that as well? I only recently learned about the existence of offset, and don't really know how to use it yet.

My apologies for anything that isn't clear in this explanation. If there is a way to send the file to you, please let me know.

 

[dmt32]

Hi

As you are using Shape objects as buttons, you can create a common code that uses Application.Caller to determine which shape called the procedure.

See if following will assist you with your project

• Make backup of your workbook
• Place following codes in a STANDARD module

Sub ShapeButton_Click()
    Dim shp         As Shape
    Dim CopyRange   As Range
    Dim CopyRow     As Boolean
    Dim NextRow     As Long
    
    Set shp = ActiveSheet.Shapes(Application.Caller)
    
    Set CopyRange = Cells(shp.TopLeftCell.Row, "A").Resize(, 4)
    
    With shp
        With .TextFrame.Characters
            CopyRow = .Text = "Copy"
            .Text = IIf(CopyRow, "Copied", "Copy")
        End With
        .Fill.ForeColor.ObjectThemeColor = IIf(CopyRow, msoThemeColorAccent6, msoThemeColorAccent1)
    End With
    
    With CopyRange
        .Interior.Color = IIf(CopyRow, RGB(112, 173, 71), xlNone)
        .Cells(1, 5).Value = IIf(CopyRow, "COPIED", "COPY")
    End With
    NextRow = Cells(1, "K").CurrentRegion.Rows.Count + 1
    If CopyRow Then Cells(NextRow, "K").Resize(, 4).Value = CopyRange.Value
End Sub

Sub AssignShapes()
 Dim shp As Shape
 
 For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Column = 6 Then shp.OnAction = "ShapeButton_Click"
 Next shp

End Sub

You only need to Run the AssignShapes code just the once – This will assign the OnAction property of each shape in Column F to the ShapeButton_Click() procedure.


I have not read all the requirements in your post but hopefully, suggestion does go in right direction to enable you with development of your project.



Dave

 

[TheHighlander]

Hi

As you are using Shape objects as buttons, you can create a common code that uses Application.Caller to determine which shape called the procedure.

See if following will assist you with your project

• Make backup of your workbook
• Place following codes in a STANDARD module

Sub ShapeButton_Click()
    Dim shp         As Shape
    Dim CopyRange   As Range
    Dim CopyRow     As Boolean
    Dim NextRow     As Long
   
    Set shp = ActiveSheet.Shapes(Application.Caller)
   
    Set CopyRange = Cells(shp.TopLeftCell.Row, "A").Resize(, 4)
   
    With shp
        With .TextFrame.Characters
            CopyRow = .Text = "COPY"
            .Text = IIf(CopyRow, "Copied", "Copy")
        End With
        .Fill.ForeColor.ObjectThemeColor = IIf(CopyRow, msoThemeColorAccent6, msoThemeColorAccent1)
    End With
   
    With CopyRange
        .Interior.Color = IIf(CopyRow, RGB(112, 173, 71), xlNone)
        .Cells(1, 5).Value = IIf(CopyRow, "COPIED", "COPY")
    End With
    NextRow = Cells(1, "K").CurrentRegion.Rows.Count + 1
    If CopyRow Then Cells(NextRow, "K").Resize(, 4).Value = CopyRange.Value
End Sub

Sub AssignShapes()
 Dim shp As Shape
 
 For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Column = 6 Then shp.OnAction = "ShapeButton_Click"
 Next shp

End Sub

You only need to Run the AssignShapes code just the once – This will assign the OnAction property of each shape in Column F to the ShapeButton_Click() procedure.


I have not read all the requirements in your post but hopefully, suggestion does go in right direction to enable you with development of your project.



Dave

Thank you for your assistance!

I love the AssignShapes macro which allows me to automatically assign your ShapeButton_Click macro to all my shapes in column 6.

It changes the text and color of the (COPY) button shape and copies the data in the chart perfectly.
There are three problems, however.
1. The top copy button (in cell F2) copies the data in row 1 (the headers: Name, Level, Kind, Number) instead of the data in row 2. All the others work fine.
2. I want the data copied to always go to the DATA COPIED box in K2:N2. It should overwrite any data already there, not go to the next row.
When the user pastes the data on a different sheet, my paste macro takes the data from that DATA COPIED box.
(This is my workaround to Excel's strange way of handling copy and paste. I want them to be able to paste no matter what they do before pasting)
3. Unfortunately, my primary question of how to change the color of the shape (in column E) based on the text in column E is not resolved by your solution.

I do not have enough knowledge of Excel coding to revise your code myself. I have only basic knowledge and haven't worked with variables and Dim statements.

Thank you very much for taking the time to try to help. I will keep your suggestion and use it to further my studies of VBA.

 

[dmt32]

It changes the text and color of the (COPY) button shape and copies the data in the chart perfectly.

That's good at least suggestions going in right direction

There are three problems, however.
1. The top copy button (in cell F2) copies the data in row 1 (the headers: Name, Level, Kind, Number) instead of the data in row 2. All the others work fine.
2. I want the data copied to always go to the DATA COPIED box in K2:N2. It should overwrite any data already there, not go to the next row.

as stated, I did not read all requirements in your post & just made a bit of a guess what you want - Above can be resolved with some minor changes to solution

3. Unfortunately, my primary question of how to change the color of the shape (in column E) based on the text in column E is not resolved by your solution.

Did not realize there was a shape in Column E as you stated in an earlier post that the column was hidden so I did not give it much consideration. Again this can be resolved but will need to locate shape object that is next to shape you press.

Try this update to the code & see if does what you want

Sub ShapeButton_Click()
    Dim shp(1 To 2) As Shape
    Dim CopyRange   As Range
    Dim CopyRow     As Boolean
    Dim NextRow     As Long
    
    Set shp(1) = ActiveSheet.Shapes(Application.Caller)
    
    Set shp(2) = GetShape(shp(1).TopLeftCell.Offset(, -1).Address)
    
    Set CopyRange = Cells(shp(1).TopLeftCell.Row, "A").Resize(, 4)
    
    With shp(1)
        With .TextFrame.Characters
            CopyRow = .Text = "Copy"
            .Text = IIf(CopyRow, "Copied", "Copy")
        End With
        .Fill.ForeColor.ObjectThemeColor = IIf(CopyRow, msoThemeColorAccent6, msoThemeColorAccent1)
    End With
    
    With CopyRange
        .Interior.Color = IIf(CopyRow, RGB(112, 173, 71), xlNone)
        .Cells(1, 5).Value = IIf(CopyRow, "COPIED", "COPY")
    End With
    
     If Not shp(2) Is Nothing Then
        shp(2).TextFrame.Characters.Text = CopyRange.Cells(1, 5).Value
        shp(2).Fill.ForeColor.RGB = IIf(CopyRow, RGB(112, 173, 71), RGB(91, 155, 213))
     End If
    
    
    If CopyRow Then Range("K2:N2").Value = CopyRange.Value
End Sub

Function GetShape(ByVal ShapeAddress As String) As Shape
   Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Address = ShapeAddress Then _
        Set GetShape = shp: Exit For
    Next shp
End Function

Note the additional function which is used to locate the shape next to shape pressed - there probably is a more elegant way to do this but for now, this should suffice.

Dave
BTW - you can share a copy of your workbook (with dummy data if needed) by using a file sharing site like dropbox & provide a link to it here.

 

[TheHighlander]

That's good at least suggestions going in right direction


as stated, I did not read all requirements in your post & just made a bit of a guess what you want - Above can be resolved with some minor changes to solution

Did not realize there was a shape in Column E as you stated in an earlier post that the column was hidden so I did not give it much consideration. Again this can be resolved but will need to locate shape object that is next to shape you press.

Try this update to the code & see if does what you want

Sub ShapeButton_Click()
    Dim shp(1 To 2) As Shape
    Dim CopyRange   As Range
    Dim CopyRow     As Boolean
    Dim NextRow     As Long
   
    Set shp(1) = ActiveSheet.Shapes(Application.Caller)
   
    Set shp(2) = GetShape(shp(1).TopLeftCell.Offset(, -1).Address)
   
    Set CopyRange = Cells(shp(1).TopLeftCell.Row, "A").Resize(, 4)
   
    With shp(1)
        With .TextFrame.Characters
            CopyRow = .Text = "Copy"
            .Text = IIf(CopyRow, "Copied", "Copy")
        End With
        .Fill.ForeColor.ObjectThemeColor = IIf(CopyRow, msoThemeColorAccent6, msoThemeColorAccent1)
    End With
   
    With CopyRange
        .Interior.Color = IIf(CopyRow, RGB(112, 173, 71), xlNone)
        .Cells(1, 5).Value = IIf(CopyRow, "COPIED", "COPY")
    End With
   
     If Not shp(2) Is Nothing Then
        shp(2).TextFrame.Characters.Text = CopyRange.Cells(1, 5).Value
        shp(2).Fill.ForeColor.RGB = IIf(CopyRow, RGB(112, 173, 71), RGB(91, 155, 213))
     End If
   
   
    If CopyRow Then Range("K2:N2").Value = CopyRange.Value
End Sub

Function GetShape(ByVal ShapeAddress As String) As Shape
   Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Address = ShapeAddress Then _
        Set GetShape = shp: Exit For
    Next shp
End Function

Note the additional function which is used to locate the shape next to shape pressed - there probably is a more elegant way to do this but for now, this should suffice.

Dave
BTW - you can share a copy of your workbook (with dummy data if needed) by using a file sharing site like dropbox & provide a link to it here.

I want to thank you for your time on this, dmt32. I can't tell you how much it means to me that someone would spend time writing code to help a stranger on the internet with a question.

I am able to understand most of the code you sent and plan to look at it carefully when I have more time this weekend and see if I can adapt it to do what I need. I also hope to learn how to code with variables (Dim statements). As I said, the level of coding you provided me is probably within my ability to learn, at my basic level of VBA coding knowledge.

I was able to get an answer to my question on another forum. The original sample file and the revised file with the complete code are also posted there.

excelforum . com/excel-programming-vba-macros/1429157-conditionally-formatting-shapes-repetitive-tasks-coded-simpler.html#post5986551

Unfortunately, the code there may be beyond my ability to understand, but I do not want to ask people to continue to work on a problem that already has a solution.
I have all of your code saved in my sample file, and plan on studying it and learning how it works. With any luck, I can adapt it to use on my primary file in the next week or two.

Thank you very much for taking the time to help me out. I will use dropbox in the future to share the file. I know it is much easier to understand if you have the actual file in front of you. Thank you for the suggestion!

 

[dmt32]

I want to thank you for your time on this, dmt32. I can't tell you how much it means to me that someone would spend time writing code to help a stranger on the internet with a question.

Your thanks appreciated but its not just myself, others here also give their free time to assist.

I was able to get an answer to my question on another forum. The original sample file and the revised file with the complete code are also posted there.

excelforum . com/excel-programming-vba-macros/1429157-conditionally-formatting-shapes-repetitive-tasks-coded-simpler.html#post5986551

Forum Rules require that you inform from the outset, that you had posted your question on another site. I normally check other sites before responding but sometimes miss one or two.

Thank you very much for taking the time to help me out. I will use dropbox in the future to share the file. I know it is much easier to understand if you have the actual file in front of you. Thank you for the suggestion!

You are welcome & we appreciate your feedback

Dave

 

[TheHighlander]

Your thanks appreciated but its not just myself, others here also give their free time to assist.


Forum Rules require that you inform from the outset, that you had posted your question on another site. I normally check other sites before responding but sometimes miss one or two.


You are welcome & we appreciate your feedback

Dave

Dave,
My apologies for the oversight on the Forum Rules. I posted here first and then posted the same question on another forum a few days later when it didn't look like I could find the answer. I also submitted this project for bids on a (non-forum) freelancer site to see how much it would cost. I didn't think to return here and update that I had posted this elsewhere.