[英]Draw circles in multiple cells based on values from another sheet
表 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
測試:
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, 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.