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

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

工作表 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% 满足您的需求。

Sheet1 Sheet2

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