Option Explicit
Sub Main()
'*** zwischen A1 und C1 (Linie und Farbe => Standard)
Call DrawArrows(Range("A1"), Range("C1"))
'*** mit Farbe (Linie => Standard)
Call DrawArrows(Range("A2"), Range("C2"), RGB(0, 0, 255))
'*** mit Doppelpfeile <----->
Call DrawArrows(Range("A3"), Range("C3"), RGB(255, 0, 0), "DOUBLE")
'*** ohne Pfeile ------
Call DrawArrows(Range("A4"), Range("C4"), RGB(0, 255, 0), "LINE")
End Sub
Private Sub DrawArrows(FromRange As Range, ToRange As Range, Optional RGBcolor As Long, Optional LineType As String)
'---------------------------------------------------------------------------------------------------
'---Script: DrawArrows------------------------------------------------------------------------------
'---Created by: Ryan Wells -------------------------------------------------------------------------
'---Date: 10/2015-----------------------------------------------------------------------------------
'---Description: This macro draws arrows or lines from the middle of one cell to the middle --------
'----------------of another. Custom endpoints and shape colors are suppported ----------------------
'---------------------------------------------------------------------------------------------------
Dim dleft1 As Double, dleft2 As Double
Dim dtop1 As Double, dtop2 As Double
Dim dheight1 As Double, dheight2 As Double
Dim dwidth1 As Double, dwidth2 As Double
dleft1 = FromRange.Left
dleft2 = ToRange.Left
dtop1 = FromRange.Top
dtop2 = ToRange.Top
dheight1 = FromRange.Height
dheight2 = ToRange.Height
dwidth1 = FromRange.Width
dwidth2 = ToRange.Width
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, dleft1 + dwidth1 / 2, dtop1 + dheight1 / 2, dleft2 + dwidth2 / 2, dtop2 + dheight2 / 2).Select
'format line
With Selection.ShapeRange.Line
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadStyle = msoArrowheadOpen
.Weight = 1.75
.Transparency = 0.5
If UCase(LineType) = "DOUBLE" Then 'double arrows
.BeginArrowheadStyle = msoArrowheadOpen
ElseIf UCase(LineType) = "LINE" Then 'Line (no arows)
.EndArrowheadStyle = msoArrowheadNone
Else 'single arrow
'defaults to an arrow with one head
End If
'color arrow
If RGBcolor <> 0 Then
.ForeColor.RGB = RGBcolor 'custom color
Else
.ForeColor.RGB = RGB(228, 108, 10) 'orange (DEFAULT)
End If
End With
End Sub
Diese Code in ein allgemeines Modul und via F5 ablaufen lassen liefert folgendes Ergebnis:
|