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.
Related
I would like to use InputBox to set the given parameter to change the table row height on cursor now position or the highlighted area. I could do this when I highlighted multi-row by mouse, but I also would like to do the same thing when I just put my cursor in a specific single row in the word table. However, when it comes to a table with vertically merged cells, I couldn't do that. VBA would show the error message: Run time error:'5991'. Is there any way to modify the row height or column width among a table with vertical and horizontal merged cells table?
Here is the script I propose:
Sub TableChangeSelectedRowHeight()
PromptBottom = "Input Row Height for Selection _________ mm"
HeaderTop = "Adjust Row Height"
UserData = InputBox(PromptBottom, HeaderTop)
Dim ToPoint As Single
ToPoint = Application.CentimetersToPoints(UserData / 10)
If StrPtr(UserData) = 0 Then
MsgBox "您取消輸入。"
ElseIf UserData = vbNullString Then
MsgBox "您沒有輸入資料。"
End
Else
If Selection.Information(wdWithInTable) = True And Selection.Rows.Count <> 1 Then 'for mutltiple row
Selection.Cells.SetHeight RowHeight:=ToPoint, _
HeightRule:=wdRowHeightAtLeast
ElseIf Selection.Information(wdWithInTable) = True And
Selection.Rows.Count = 1 Then 'for single row
aa = Selection.Cells(1).RowIndex
Selection.Rows(aa).SetHeight RowHeight:=ToPoint, _
HeightRule:=wdRowHeightAtLeast 'There are some problems here
Else
MsgBox "The insertion point is not in a table."
End If
End If
End Sub
and when I conduct the sub the following error message would show:
Run time error:5991
Cannot access individual rows in the collection because the table has vertically merged cells.
Try something along the lines of:
Dim Cl As Cell, Rng As Range, r As Long
With Selection
If .Information(wdWithInTable) = True Then
For r = .Cells(1).RowIndex To .Cells(.Cells.Count).RowIndex
Set Rng = Nothing
With .Tables(1)
For Each Cl In .Range.Cells
With Cl
If .RowIndex = r Then
If Rng Is Nothing Then
Set Rng = .Range
Else
Rng.End = .Range.End
End If
End If
End With
Next
Rng.Cells.HeightRule = wdRowHeightAtLeast
Rng.Cells.Height = CentimetersToPoints(UserData / 10)
End With
Next
Else
MsgBox "The insertion point is not in a table."
End If
End With
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
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
I have an issue with filling blank cells of a column.
I have 3 Column headings in A, B, C.
Under that I have variable amounts of rows, but column A and B will always have data.
Column C could have gaps. How could I do something similar to:
Edit > Go To > Special > Blanks, type = in the formula bars, hit the up arrow then Ctrl+Enter
EXCEPT, with the macro only going up until the last row of A and no further.
I have:
Sub FillCellsFromAbove()
' Turn off screen updating to improve performance
Application.ScreenUpdating = False
On Error Resume Next
' Look in column A
With Columns(3)
' For blank cells, set them to equal the cell above
.SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
'Convert the formula to a value
.Value = .Value
End With
Err.Clear
Application.ScreenUpdating = True
End Sub
It however fills right from the bottom of the page and not from where the last "A" value is.
Don't use all of Column C -- first determine how far the data in Column A extends and then grab that many cells in column C:
Sub FillCellsFromAbove()
Dim R As Range, n As Long
n = Range("A:A").Rows.Count
n = Cells(n, "A").End(xlUp).Row
Set R = Range(Cells(1, 3), Cells(n, 3))
Application.ScreenUpdating = False
On Error Resume Next
With R
' For blank cells, set them to equal the cell above
.SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
'Convert the formula to a value
.Value = .Value
End With
Err.Clear
Application.ScreenUpdating = True
End Sub
You might want to test for blanks before attempting to put formulas into cells that may not exist.
With Columns(3).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 1)
If CBool(Application.CountBlank(.Cells)) Then
' For blank cells, set them to equal the cell above
.Cells.SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
'Convert the formula to a value
.Value = .Value
End If
End With
I'm trying to write a macro to change the colors of rows when the values in column B change. Column A will be my controlling column using 1's and 0's, i.e. column A will stay a 1 as long as column B stays the same; whenever B changes, A will flip to a 0, and so on.
I can get it to color the rows correctly when the values in column B change, but the problem arises when I filter the data. For example: let's say I have B2-B4 set to "test1", B5-B7 set to "test2", and B8-B10 set to "test3", then I filter column B to not include "test2". Originally, the rows would be colored differently where the column values changed, but rows B2-B4 and B8-B10 are set to the same color and now they're touching since the "test2" rows are hidden.
Here's the code I used to color the rows, but it doesn't work for filtering:
Sub ColorRows()
Dim This As Long
Dim Previous As Long
Dim LastRow As Long
Dim Color As Integer
Dim R As Long
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
RwColor = Array(15,0)
Color = 0
For R = 2 To LastRow
This = Cells(R, 1).Value
Previous = Cells(R - 1, 1).Value
If This <> Previous Then Color = 1 - Color
Range("A" & R & ":M" & R).Select
Selection.Interior.ColorIndex = RwColor(Color)
Next R
End Sub
How can I fix it so that even after filtering the rows are colored correctly when there is a change in column values?
Here's a way to do this:
1.) Insert the code below as a UDF in a code module.
2.) Then put the formula in A, as A2: =analyseVisible(B2).
This will compare B-cells to the next visible cell above and result in a 'rank'-counter in A.
Now that the counter in A in contiunous (even if rows are hidden), you can use MOD 2 to color it with conditional formatting:
3.) Add a conditional format (from A2 for the whole table): =MOD($A2,2)=1 and set the fill color.
If you use the filter now or change values in B, the rows are re-colored in realtime.
Public Function analyseVisible(r As Range) As Integer
Dim i As Long
If Application.Caller.Row <= 2 Or _
r.Row <> Application.Caller.Row Then
analyseVisible = 1
Exit Function
End If
i = r.Row - 1
While r.Worksheet.Rows(i).Hidden And i > 1
i = i - 1
Wend
If i = 1 Then
analyseVisible = 1
Else
analyseVisible = r.Worksheet.Cells(i, Application.Caller.Column).Value
If r.Worksheet.Cells(i, r.Column).Value <> _
r.Value Then analyseVisible = analyseVisible + 1
End If
End Function
The code below handles the issue by checking only the used & visible rows. It works pretty well, but I was unable to figure out how to fire it when the filter changes. It also does it's comparisons directly on the values that are changing.
Private Sub colorRows()
Dim this As Variant
Dim previous As Variant
Dim currentColor As Long
Dim rng As Range 'visible range
Dim c As Range ' cell
' pick a color to start with
currentColor = vbYellow
' rng = used and visible cells
Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
For Each c In rng ' For each cell that is visible and used
If Not c.Row = 1 Then ' skip header row
this = c.Value
'some simple test logic to switch colors
If this <> previous Then
If currentColor = vbBlue Then
currentColor = vbYellow
ElseIf currentColor = vbYellow Then
currentColor = vbBlue
End If
End If
'set interior color
c.Interior.color = currentColor
previous = this
End If
Next c
End Sub
Then, in the module of the worksheet that you want to colorize, call the sub from the Worksheet_Activate() event. (In reality, you probably want a different event. I mostly work with Access, so I don't really know what's available to you. I'm just trying to point you in the right direction to what I'm sure is your next question if you stick with the method you started with.)
Private Sub Worksheet_Activate()
colorRows
End Sub