Textfelder ein einem Bereich kopieren

Sub Textfeld() 'ein Textfeld über der aktuellen Zelle erstellen und mit Text füllen
Dim strText As String, Obj As Object, i As Integer, BrHo As Currency
Dim strStartzelle As String
strStartzelle = ActiveCell.Address
strText = InputBox("Welcher Text soll als Bemerkung eingetragen werden?")
If strText = "" Then Exit Sub
Set Obj = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 675#, 474.75, _
225#, 22.5)
With Obj
.Left = ActiveCell.Left
.Top = ActiveCell.Top
BrHo = 0
For i = 0 To 2
BrHo = BrHo + ActiveCell.Offset(i, 0).Height
Next i
.Height = BrHo
BrHo = 0
For i = 0 To 3
BrHo = BrHo + ActiveCell.Offset(0, i).Width
Next i
.Width = BrHo
.Select
With Selection
.Characters.Text = strText
With .Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 13
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End With
End Sub
Sub Textfelder_in_Markierung_löschen() 'zuvor erstelltes Textfeld bei Bedarf wieder löschen
Dim objTextfeld
Dim rngBereich As Range
Set rngBereich = Selection
For Each objTextfeld In ActiveSheet.Shapes
If objTextfeld.Type = msoTextBox Then
If Not Intersect(objTextfeld.TopLeftCell, rngBereich) Is Nothing Then objTextfeld. _
Delete
End If
Next
Set rngBereich = Nothing
End Sub