I am trying to use a variable to select a certain shape and color it.
So I would like to use Sheet2.Shapes(varShapename).Select to select a shape (instead of using the actual name of the shape) and then change it's color. But it seems that I HAVE to use the actual name of the shape or use an index and I can't pass a variable.
What am I doing wrong?
Sub KeyCellsChanged()
Dim Cell As Object
' If the values in B257:D277 are greater than 0
For Each Cell In Range("B257:D277")
If Cell < 0 Then
' Make the background color of the cell the 3rd color on the
' current palette.
Cell.Interior.ColorIndex = 3
' Select the first cell of the row, which holds the names of the shapes to change
ActiveSheet.Cells(ActiveCell.Row, 1).Select
Set shapeName = Selection
Sheet2.Shapes(shapeName).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
' Otherwise, set the background to none (default).
Cell.Interior.ColorIndex = xlNone
End If
Next Cell
End Sub
I get a runtime error 5.
Instead of
Set shapeName = Selection
use this instead
shapeName = ActiveCell.Value
Related
I'm trying to create a excel file where I will have shapes.
That shapes i'm trying to connect to cell values.
So when I click on button start, excel will go through the cell values, of cell value is X, I want shape X to blink red, and if cell value is Y cell will be green.
For now i programmed code for going through cells in one column and changing its color to green and red:
Sub test()
Dim sh As Shape
Dim area As String
Set sh = Sheet1.Shapes("X")
Range("A1").Select
Do Until ActiveCell.Value = ""
area = ActiveCell.Value
If area = "X" Then
sh.Fill.ForeColor.RGB = rgbRed
End If
ActiveCell.Offset(1, 0).Select
Loop End Sub
I have a problem with programming the code to change the name of cell and to change the color of other shapes.
You have to wait about 1 second between the selection of the cells in order to make it work. With your code and using Select Cell, something like this should work:
Sub test()
Dim sh As Shape
Dim area As String
Set sh = ActiveSheet.Shapes("X")
Range("A1").Select
Do Until ActiveCell.Value = ""
area = ActiveCell.Value
If area = "X" Then
sh.Fill.ForeColor.RGB = rgbRed
Application.Wait Now + #12:00:01 AM#
ElseIf area = "Y" Then
sh.Fill.ForeColor.RGB = rgbGreen
Application.Wait Now + #12:00:01 AM#
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
In general, using Select in VBA is considered a bad practice, but in this case it makes the "application" look better, because you can follow the current cell.
I have a piece of code that will allow me to find the next free cell in column F, where an operator will input a Weight.
I wanted to help by highlighting the cells in a range close to where the input needs to be done (this can help to check that the entry is correct without filtering).
I can do that with the code below but I'm trying to remove the highlighting after the cell is written and I'm failing. I tried an approach with 'Do Until' but was also not satisfactory. The code runs but it does not remove the highlight once the user adds a value.
I have also tried using Wait functions but they freeze Excel completely (I cannot modify any value). Additionally, when I run in debug and use a random iteration to modify the Cell value, my code works.
'Find the last non-blank cell in column F (aka, column 6)
' We will add i rows to make the ith blank (in the for loop)
PreFree = Cells(Rows.Count, 6).End(xlUp).Row
NextFree = PreFree + 1
' Select Cell for manual input
Range("F" & NextFree).Select
'Do Until emptyWeight = False
If ThisWorkbook.Sheets("Input").Range("F" & NextFree) = "" Then
emptyWeight = True
Range(Cells(NextFree, "C"), Cells(NextFree, "F")).Interior.Color = RGB(181, 244, 0)
Else
Range(Cells(NextFree, "C"), Cells(NextFree, "F")).Interior.Color = RGB(255, 255, 255)
emptyWeight = False
End If
As Sir BruceWayne said, you can do this with Worksheet_Change event.
Private Sub Worksheet_Change(ByVal Target As Range)
' Declare and prepare the intersection & union of ranges
Dim rIntersect As Range
Set rIntersect = Intersect(Target.Offset(1, 0), Sheets("YourSheet").Range("F:F"))
' Exit this event if there is no change in column f
If rIntersect Is Nothing Then Exit Sub
' Include TargetCell
Set rIntersect = Union(Target, rIntersect)
' Declare the 'each range', in case the user will paste values into column f
Dim rEach As Range
' Will loop through each cell that made a change in column f
For Each rEach In rIntersect
' Give default color.
rEach.Interior.Color = RGB(255, 255, 255)
' And test if the value <blank>, sets color if it is true.
If rEach.Value = "" Then rEach.Interior.Color = RGB(181, 244, 0)
Next
End Sub
Hope this works for you. Good luck!
To OP, paste your code here
Public Function ColorSum(ByVal target As range, ByVal MyColor As String)
Dim Blacksum As Long, Othersum As Long, cel As range
Application.Volatile
Blacksum = 0
Othersum = 0
For Each cel In target
If IsNumeric(cel.Value) Then
If cel.Font.ColorIndex = 1 Then
Blacksum = Blacksum + cel.Value
Else
Othersum = Othersum + cel.Value
End If
End If
Next cel
ColorSum = IIf(LCase(MyColor) = "black", Blacksum, Othersum)
End Function
I am using the above code to calculate black colored sum totals and red colored sum totals in different rows of the excel sheet, but as you know there is a Automatic black color in Font options, when I am entering values with that Automatic color ( Black ) it doesn't sum under Black total, the Automatic Color (Black) cell value's total goes to Red color total instead of Black color total sum, I want the Automatic Black sum total should be included on Black sum total.
I am using
A11=colorsum(A1:A10,"black")
A11=colorsum(A1:A10,"red")
xlColorIndexNone (and xlNone) is a constant with a value of -4142.
xlColorIndexAutomatic (and xlAutomatic) is a constant with a value of -4105.
Using Excel's GUI to set a cell's colour to be "Automatic" will often set the ColorIndex to 1 but, if it was another colour before being set, it will set the ColorIndex to -4105 (i.e. xlColorIndexAutomatic).
So I would suggest you check for each of 1, xlColorIndexNone (or xlNone), and xlColorIndexAutomatic (or xlAutomatic).
In other words, change
If cel.Font.ColorIndex = 1 Then
to
If cel.Font.ColorIndex = 1 Or _
cel.Font.ColorIndex = xlColorIndexNone Or _
cel.Font.ColorIndex = xlColorIndexAutomatic Then
Long time ago I programmed vba but I think that the color index = 0 or xlNone or xlColorIndexAutomatic or xlColorIndexNone is the automatic and Black has colorIndex =1 and that is the reason. Could you try and play with the above mentioned suggested values?
using ColorIndex as reference can be difficult because you'll have to memorize the index. i'd suggest use color
Function SumByFontColor(MyRange As Range, Optional MyColor As Range)
Dim Rng As Range
Dim Col As Long
Application.Volatile
If MyColor Is Nothing Then
Col = Application.Caller.Font.Color
Else
Col = MyColor(1).Font.Color
End If
SumByFontColor = 0
For Each Rng In MyRange
If Rng.Font.Color = Col Then
SumByFontColor = SumByFontColor + Rng.Value2
End If
Next Rng
End Function
there are two ways to use the formula, i hope the code is self explanatory:
it must be noted that updating the color of a cell does not initiate the sheet to recalculate its formulas. So you must manually press F9 to recalculate each time you update the cell's color.
I need to assign the value 1 or 0 based on the color of my cells (Red or Blue). I've heard alot about how to assign colors to values but not the other way. Im a beginner but I believe I will need to use an IF Statement in VBA for this, I haven't figured out how to assign a color as an input for an IF statement. Any help would be appreciated!
Thank You
Excel 2013
In the first example that follow I made the assumption that you want blue cells equal to 1 and red cells equal to 0.
Sub ifBlueMakeCellValueEQ1()
Dim r As Range
Dim rCell As Range
Set r = Selection.Cells
For Each rCell In r
With rCell
Select Case .Interior.Color
Case Is = vbBlue
.Value = 1
Case Is = vbRed
.Value = 0
End Select
End With
Next
End Sub
to use this, first select a range of cells then run the macro.
If that works then ignore the remainder of this answer
If the values of your cells aren't changing to 1 or 0 it means your cell's colors aren't equal to excel's idea of blue and red (vbBlue and vbRed, respectively).
If you run into this problem do this: click on a 'blue' cell. Go to the VBE Immediate window, type the command "?activecell.interior.colorindex", hit enter. The integer that is returned should be used in the following code in place of {BLUECOLORINDEX}
Sub ifBlueMakeCellValueEQ1()
Dim r As Range
Dim rCell As Range
Set r = Selection.Cells
For Each rCell In r
If rCell.Interior.ColorIndex = {BLUECOLORINDEX} Then rCell.Value = 1
Next
End Sub
I'm writing a macro that basically draws a circle for every value in a column with a size based on that value, however some of the cells are blank and I just need to skip over them. I run into an error when I hit the first blank cell. Here's the code I have so far:
Sub plotCircles()
Set R = Range("D7:D205")
For Each Value In R
If Value = "" Then
Value = Value + 1
Else
Set shp = ActiveSheet.Shapes.AddShape(msoShapeOval, 10, 10, Value, Value)
End If
Next Value
End Sub
Try this:
Sub PlotCircles()
Dim r As Range, c As Range, shp As Shape
Set r = Sheet1.Range("D7:D205") 'change to suit
For Each c In r
With c
If .Value <> "" Then
Set shp = Sheet1.Shapes.AddShape _
(msoShapeOval, .Left, .Top, .Value, .Value)
Else
.Value = .Value + 1
End If
End With
Next
End Sub
I don't know why you hardcode your Left and Top argument for the AddShape method.
That will draw all the circles in the same location.
Above however draws the circles in the cell where you get your values from.
You can adjust that to suit your needs. HTH.