问题描述
工作表 1......................................工作表 2
我目前正在尝试制作一个宏,根据(工作表 2)中的单元格值在(工作表 1)中绘制一个圆圈。
假设从(工作表 2)中查找是或否,然后根据(工作表 1)中的单元格值为每一行圈选是或否
对我来说,当前的结果是所有圆圈都绘制在(Sheet 1)中的(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,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
解决方法
已测试:
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
,
一个解决方案。 它根据 Sheet2 中的 YES/NO 值在 Sheet1 的右侧单元格中添加一个圆圈。 这很粗糙,您必须对其进行调整以使其 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)
.Fill.Visible = msoFalse
End With
Else
With pRange.Cells(1,.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,False
End If
Next i
End Sub