AW: Geht nicht!
21.06.2014 18:26:23
Mullit
Hallo,
das könnte man sich vielleicht selbst bauen;
zunächst müsste man Deine Gruppierungen auflösen.
Code in das Klassenmodul der Arbeitsmappe:
Option Explicit
Private msngArrShpSize(1 To 2) As Single
Private mcolShapes As Collection
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set mcolShapes = Nothing
End Sub
Private Sub Workbook_Open()
Set mcolShapes = New Collection
With ActiveSheet.GroupObjects("Gruppieren 5")
msngArrShpSize(1) = .Height
msngArrShpSize(2) = .Width
End With
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call prcRefresh
End Sub
Private Sub prcRefresh()
Dim objRect As Rectangle
Dim strName As String
Dim strArrGroupNames() As String
Dim lngResize As Long, lngIndex As Long
Static blnArrInit(1 To 3) As Boolean
Static sngOldHeight As Single, sngSize As Single
If Not blnArrInit(1) Then
sngOldHeight = msngArrShpSize(1)
blnArrInit(1) = Not blnArrInit(1)
End If
With ActiveSheet.GroupObjects("Gruppieren 5")
If .Height <> sngOldHeight Then
lngResize = lngResize + 2 * (.Height - msngArrShpSize(1)) \ 20
strName = .Name
sngOldHeight = .Height
With .ShapeRange
Redim strArrGroupNames(1 To .GroupItems.Count) As String
For lngIndex = 1 To .GroupItems.Count
strArrGroupNames(lngIndex) = .GroupItems(lngIndex).Name
Next
End With
.Ungroup
With ActiveSheet
If Not blnArrInit(3) Then
mcolShapes.Add .Rectangles("Rechteck 2")
mcolShapes.Add .Rectangles("Rechteck 4")
blnArrInit(3) = Not blnArrInit(3)
End If
For Each objRect In mcolShapes
With objRect.Characters.Font
If Not blnArrInit(2) Then
sngSize = .Size
blnArrInit(2) = Not blnArrInit(2)
End If
.Size = sngSize + lngResize
End With
Next
.Shapes.Range(Array(strArrGroupNames(1), strArrGroupNames(2), _
strArrGroupNames(3))).Group.Name = strName
End With
End If
End With
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 14
Zunächst ist nur die Height-Anpassung eingebaut.
Der Refresh findet immer beim Neuklick in eine Zelle statt,
wenn man die Textanpasssungen dynamisch beim Grösser/Kleiner-Ziehen
haben möchte, müsste man u.U. noch Timer-Programmierung einbauen...
Gruß,