根据另一个工作表中的值在多个单元格中绘制圆圈

Question

表 1..................................表 2

我目前正在尝试根据（表 2）中的单元格值制作一个在（表 1）中绘制圆圈的宏。

假设从（表 2）中查找是或否，然后根据（表 1）中的单元格值为每一行圈出是或否

对我来说，目前的结果是所有圆圈都只绘制在（表 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, _
                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

Answer 1

测试：

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

Answer 2

一个解法。 它根据 Sheet2 中的 YES/NO 值在 Sheet1 的右侧单元格中添加一个圆圈。 这很粗糙，您必须对其进行调整以 100% 满足您的需求。

表 1 表2

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