Makro Excel: Um einen Kreis in bestimmten Bereich in Zelle

Question

einfügen Ich habe einen Kreis, der einen festen Durchmesser und Mittelpunkt hat. Was ich jetzt tun muss, ist den Kreis in den gegebenen Bereich einzufügen. ZB 11 Kästchen mit Spalten und 10 Kästchen mit Zeilen, die in die Excel-Zelle eingefügt werden sollen. Nach Eingabe des angegebenen Bereichs befindet sich der Kreis innerhalb des ausgewählten Bereichs mit seiner festen Mitte, aber die Boxen haben unterschiedliche Maße für ihre Höhe und Breite. Meine Frage ist, wie setze ich den Kreis in einen bestimmten Bereich (wie in 11 x 10 oder 9 x 12) mit unterschiedlicher Höhe und Breite der Zellen?

Mein Code:

Sub DrawCircleWithCenter() 
Dim cellwidth As Single 
Dim cellheight As Single 
Dim ws As Worksheet 
Dim rng As Range 
Dim Shp2 As Shape 


CellLeft = Selection.Left 
CellTop = Selection.Top 

ActiveSheet.Shapes.AddShape(msoShapeOval, CellLeft, CellTop, 565/2, 565/2).Select 
Selection.ShapeRange.Fill.Visible = msoFalse 
With Selection.ShapeRange.Line 
    .Visible = msoTrue 
    .ForeColor.RGB = RGB(0, 0, 0) 
    .Transparency = 0 
End With 

i = 182 
Set Shp2 = ActiveSheet.Shapes.AddShape(i, CellLeft, CellTop, 20, 20) 
Shp2.ShapeStyle = msoShapeStylePreset1 
Set rng = ActiveWindow.VisibleRange 

Selection.Left = rng.Width/2 - Selection.Width/2 
Selection.Top = rng.Height/2 - Selection.Height/2 
Shp2.Left = rng.Width/2 - Shp2.Width/2 
Shp2.Top = rng.Height/2 - Shp2.Height/2 


End Sub 

Answer 1

Wenn ich Sie verstehen, könnte dies richtig sein, was Sie nach:

Sub DrawCircleWithCenter(rng As Range) 
    Dim Shp1 As Shape, Shp2 As Shape 

    Set Shp1 = ActiveSheet.Shapes.AddShape(msoShapeOval, rng.Left, rng.Top, rng.Width, rng.Height) 
    Shp1.Fill.Visible = msoFalse 
    With Shp1.Line 
    .Visible = msoTrue 
    .ForeColor.RGB = RGB(0, 0, 0) 
    .Transparency = 0 
    End With 

    Set Shp2 = ActiveSheet.Shapes.AddShape(182, rng.Left, rng.Top, 20, 20) 
    Shp2.ShapeStyle = msoShapeStylePreset1 

    Shp1.Left = rng.Left 
    Shp1.Top = rng.Top 
    Shp2.Left = rng.Left + rng.Width/2 - Shp2.Width/2 
    Shp2.Top = rng.Top + rng.Height/2 - Shp2.Height/2 
End Sub 

Sub Test() 
    Dim rng As Range 
    Set rng = Selection 
    DrawCircleWithCenter rng 
End Sub 

Sie können die Test-Unterprogramm ändern Sie den Bereich, den Sie sind zu liefern nach. Im obigen Fall verwende ich die Auswahl, die der Benutzer im vorliegenden Arbeitsblatt markiert hat, um das Kreuz und das ovale Zentrum darin zu zeichnen. Wenn Sie eine quadratische Fläche wählen, wird das Oval zu einem Kreis, mit einer rechteckigen Fläche wird es zu einer Ellipse gequetscht. Es funktioniert auch, wenn Sie in dem von Ihnen ausgewählten Bereich unterschiedliche Zellenbreiten und -höhen haben.