[英]Draw circles in multiple cells based on values from another sheet
Sheet1....................................Sheet2表 1..................................表 2
I'm currently trying to make a Macro that draws a circle in (Sheet 1) based on the cell value in (Sheet 2).我目前正在尝试根据(表 2)中的单元格值制作一个在(表 1)中绘制圆圈的宏。
It is suppose to look for whether it is Yes or No from (Sheet 2), and then circling either a Yes or No for each row based on the cell value in (Sheet 1)假设从(表 2)中查找是或否,然后根据(表 1)中的单元格值为每一行圈出是或否
The current results for me is that all the circles are drawn in only (1) cell in (Sheet 1), and then selects the next cell.对我来说,目前的结果是所有圆圈都只绘制在(表 1)中的(1)单元格中,然后选择下一个单元格。
Removing For i = 0 To 4
and If
functions results in drawing circles in all the cells of both ranges in (Sheet 1).删除
For i = 0 To 4
和If
函数会导致在(表 1)中两个范围的所有单元格中绘制圆圈。
Sub DrawCricles()
Dim Arng As Range, drawRng As Range, infoRng As Range, YesRng As Range, NoRng As Range,
Set drawRng = Application.Selection
Set infoRng= Worksheets("Sheet2").Range("A1:A5") 'All the values in this range is either Yes/No
Set YesRng = Worksheets("Sheet1").Range("A1,A2,A3,A4,A5") 'All the values in this range is Yes
Set NoRng = Worksheets("Sheet1").Range("C1,C2,C3,C4,C5") 'All the values in this range is No
For i = 0 To 4
NoRng(i).Select
If infoRng(i).Value = "NO" Then
NoRng(i).Select
For Each Arng In drawRng.Areas
With Arng
x = Arng.Height * 0.1
y = Arng.Width * 0.1
Application.Worksheets("Sheet1").Ovals.Add Top:=.Top - x, Left:=.Left - y, _
Height:=.Height + 2 * x, Width:=.Width - 5 * y
With Application.Worksheets("Sheet1").Ovals(Worksheets("Sheet1").Ovals.Count)
.Interior.ColorIndex = xlNone
.ShapeRange.Line.Weight = 1.25
End With
End With
Next
Else
YesRng(i).Select
For Each Arng In drawRng.Areas
With Arng
x = Arng.Height * 0.1
y = Arng.Width * 0.1
Application.Worksheets("Sheet1").Ovals.Add Top:=.Top - x, Left:=.Left + y * 4, _
Height:=.Height + 2 * x, Width:=.Width - 3 * y
With Application.Worksheets("Sheet1").Ovals(Worksheets("Sheet1").Ovals.Count)
.Interior.ColorIndex = xlNone
.ShapeRange.Line.Weight = 1.25
End With
End With
Next
End If
Next
Tested:测试:
Sub DrawCircles()
Dim c As Range, infoRng As Range, YesNoRng As Range, i As Long, yn
Set infoRng = Worksheets("Sheet2").Range("A1:A5")
Set YesNoRng = Worksheets("Sheet1").Range("A1:B5") 'both columns...
yn = UCase(infoRng.Cells(i).Value)
For i = 1 To infoRng.Cells.Count 'index from 1 not zero
'corresponding Y/N cell - choose based on Y/N
yn = UCase(infoRng.Cells(i).Value)
With YesNoRng.Cells(i, IIf(yn = "NO", 2, 1))
' .Parent is the Worksheet
' Ovals.Add() returns the added shape, so you can use it directly here
With .Parent.Ovals.Add(Top:=.Top + 3, Left:=.Left + 3, _
Height:=.Height - 6, Width:=.Width - 6)
.Interior.ColorIndex = xlNone
.ShapeRange.Line.Weight = 1.25
End With
End With
Next i
End Sub
A solution.一个解法。 It adds a circle in the right cell in Sheet1 depending on YES/NO value in Sheet2.
它根据 Sheet2 中的 YES/NO 值在 Sheet1 的右侧单元格中添加一个圆圈。 This is rough, you'll have to adapt it to 100% fit your needs.
这很粗糙,您必须对其进行调整以 100% 满足您的需求。
Sub DrawCircle(ByRef pRange As Range, ByRef pSheet As Worksheet, _
Optional ByVal pNo As Boolean)
Dim oVal As Object
If pNo Then 'NO
With pRange.Cells(1, 1)
pSheet.Shapes.AddShape msoShapeOval, .Left, .Top, .Width, .Height
End With
With pSheet.Shapes(pSheet.Shapes.Count)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Fill.Visible = msoFalse
End With
Else
With pRange.Cells(1, 1)
pSheet.Shapes.AddShape msoShapeOval, .Left, .Top, .Width, .Height
End With
With pSheet.Shapes(pSheet.Shapes.Count)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Fill.Visible = msoFalse
End With
End If
End Sub
Sub TestIt()
Dim infoRng As Range, YesRng As Range, NoRng As Range
Dim rCell As Range
Dim i As Long
Set infoRng = Worksheets("Sheet2").Range("A1:A5") 'All the values in this range is either Yes/No
Set YesRng = Worksheets("Sheet1").Range("A1:A5") 'All the values in this range is Yes
Set NoRng = Worksheets("Sheet1").Range("B1:B5") 'All the values in this range is No
For i = 1 To infoRng.Rows.Count
If infoRng.Cells(i, 1).Value = "NO" Then
Set rCell = NoRng.Cells(i, 1)
DrawCircle rCell, ThisWorkbook.Worksheets("Sheet1"), True
Else
Set rCell = YesRng.Cells(i, 1)
DrawCircle rCell, ThisWorkbook.Worksheets("Sheet1"), False
End If
Next i
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.