(28.08.2021, 08:44)schauan schrieb: [ -> ]Hallöchen,
VBA:
Oder Du hast eine Standardgröße und stellst diese vor dem Speichern der Datei wieder her.
Oder ...
Diese Schnipsel gehören nicht in ein Modul, sondern unter Microsoft Exel Objekte in DieseArbeitsmappe.
Update: Diese Lösung funktioniert auch, wenn die Arbeitsmappe mehrere Tabellen enthält und auch dann, wenn zwischen Tabellen mehrfach hin- und hergewechselt wird.
Diese Lösung setzt voraus, dass die Seitenverhälltnisse aller Kommentare identisch sind, z. Bsp.: Vereinslogo wurde als Hintergrundbild eingefügt.
Diese Lösung bringt jedoch leider auch ein Problem mit sich, wenn die Tabelle Hunderte oder über Tausend Kommentare enthält, weil dann das Speichern der Datei für Benutzer*innen inakzeptabel lange dauert.
Code:
Option Explicit
Dim ScaleValue1(1 To 100) As Double
Dim AktiveTabelle(1 To 100) As String
Dim c As Integer
Dim cmtc As Long
Dim u As Integer
Dim v As Integer
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim objComment As Comment
Dim ScaleValue2 As Double
cmtc = 0
u = 0
v = 0
For u = 1 To 100 '** bei wiederholtem sofortigen Wechsel zur selben Tabelle (mit nur einer anderen Tabelle dazwischen), _
wird die Tabelle nur einmal berücksichtigt, die anderen Kommentar-Seitenverhältnisse derselben Tabelle werden zu Null gesetzt _
und an Hand dessen übersprungen; so werden Mehrfach-Berechnungen vermieden.
For v = (u + 1) To 100
If AktiveTabelle(u) = AktiveTabelle(v) Then
ScaleValue1(v) = 0
End If
Next v
Next u
For c = 1 To c
If AktiveTabelle(c) = "" Then
GoTo LabelSkip2
ElseIf ScaleValue1(c) = 0 Then '** Tabellen deren Kommentar-Seitenverhältnis zu Null gesetzt wurde, werden übersprungen
GoTo LabelSkip1
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each objComment In Worksheets(AktiveTabelle(c)).Comments
cmtc = cmtc + 1
'Resize
With objComment.Shape
.LockAspectRatio = msoFalse
.TextFrame.AutoSize = False
ScaleValue2 = .Height / .Width
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; AktiveTabelle(c)
If ScaleValue2 <> ScaleValue1(c) Then
.Width = 150
.Height = .Width * ScaleValue1(c)
.LockAspectRatio = msoTrue
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; .Width; .Height
End If
End With
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
LabelSkip1:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
DoEvents
Next c
LabelSkip2:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
For c = 1 To c
Debug.Print c; ScaleValue1(c); AktiveTabelle(c)
Next
End Sub
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim objComment As Comment
Dim ScaleValue2 As Double
cmtc = 0
u = 0
v = 0
For u = 1 To 100
For v = (u + 1) To 100
If AktiveTabelle(u) = AktiveTabelle(v) Then
ScaleValue1(v) = 0
End If
Next v
Next u
For c = 1 To c
If AktiveTabelle(c) = "" Then
GoTo LabelSkip2
ElseIf ScaleValue1(c) = 0 Then
GoTo LabelSkip1
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each objComment In Worksheets(AktiveTabelle(c)).Comments
cmtc = cmtc + 1
'Resize
With objComment.Shape
.LockAspectRatio = msoFalse
.TextFrame.AutoSize = False
ScaleValue2 = .Height / .Width
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; AktiveTabelle(c)
If ScaleValue2 <> ScaleValue1(c) Then
.Width = 150
.Height = .Width * ScaleValue1(c)
.LockAspectRatio = msoTrue
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; .Width; .Height
End If
End With
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
LabelSkip1:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
DoEvents
Next c
LabelSkip2:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
For c = 1 To c
Debug.Print c; ScaleValue1(c); AktiveTabelle(c)
Next
End Sub
Code:
Private Sub Workbook_Open()
Dim objComment As Comment
Dim i As Integer
Dim SV As Double
i = 0
c = 0
c = c + 1
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV = .Height / .Width
End With
If i = 1 Then GoTo LabelFinish
Next
LabelFinish:
ScaleValue1(c) = SV
AktiveTabelle(c) = ActiveSheet.Name
Debug.Print c; SV; ScaleValue1(c); AktiveTabelle(c)
End Sub
Code:
Private Sub Workbook_SheetActivate(ByVal Sh As Object) '** Seitenverhältnis beim Tabellenwechsel wird ermittelt
Dim objComment As Comment
Dim i As Integer
Dim SV As Double
i = 0
c = c + 1
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV = .Height / .Width
End With
If i = 1 Then GoTo LabelFinish
Next
LabelFinish:
ScaleValue1(c) = SV
AktiveTabelle(c) = ActiveSheet.Name
Debug.Print c; SV; ScaleValue1(c); AktiveTabelle(c)
End Sub
Im Modul1 befindet sich zum Durcheinanderbringen aller Kommentare folgendes Schnipsel:
Code:
Option Explicit
Private Sub comments_mathematical_exact_arrangement()
Dim objComment As Comment
Dim i As Long
Dim j As Double
Dim z As Double
i = 0
If ActiveSheet.Comments.Count = 0 Then
MsgBox "No comments in entire sheet"
Exit Sub
End If
' Alle Kommentare des aktuellen Arbeitsblatts durchlaufen
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each objComment In ActiveSheet.Comments
i = i + 1
z = Rnd
If z <= 0.1 Then
j = i * z ^ 1
ElseIf z <= 0.2 Then j = i * z ^ 2
ElseIf z <= 0.3 Then j = i * z ^ 3
ElseIf z <= 0.4 Then j = i * z ^ 4
ElseIf z <= 0.5 Then j = i * z ^ 5
ElseIf z <= 0.6 Then j = i * z ^ 6
ElseIf z <= 0.7 Then j = i * z ^ 7
ElseIf z <= 0.8 Then j = i * z ^ 8
ElseIf z <= 0.9 Then j = i * z ^ 9
ElseIf z <= 1 Then j = i * z ^ 10
End If
With objComment
.Shape.TextFrame.AutoSize = True
If j <= 10 Then
.Shape.Top = .Parent.Top + (.Parent.Height * (j / 10))
.Shape.Left = .Parent.Left + (.Parent.Width * (j / 10))
ElseIf j <= 100 Then
.Shape.Top = .Parent.Top + (.Parent.Height * (j / 10))
.Shape.Left = .Parent.Left + (.Parent.Width * (j / 100))
ElseIf j <= 1000 Then
.Shape.Top = .Parent.Top + (.Parent.Height * (j / 10))
.Shape.Left = .Parent.Left + (.Parent.Width * (j / 1000))
ElseIf j <= 10000 Then
.Shape.Top = .Parent.Top + (.Parent.Height * (j / 100))
.Shape.Left = .Parent.Left + (.Parent.Width * (j / 100))
End If
End With
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
Gerne wiederhole ich mich selbst:
(01.09.2021, 18:26)TxbyFmjy schrieb: [ -> ]Eine abgerundete Lösung zu finden, ist nicht trivial.
[
attachment=40066]
(02.09.2021, 18:30)schauan schrieb: [ -> ]Hallöchen,
warum postest Du eigentlich die Codes mit ...SelectionChange... wenn die Deinem Anspruch wegen der eingeschränkten UNDO-Funktion nicht gerecht werden?
Ich hatte dieses funktionierende Schnipsel ausgearbeitet, dann erst entdeckt welcher Nachteil damit verbunden ist und dieses Schnipsel der Vollständigkeit halber trotzdem gepostet. Im Schnipsel steht der Nachteil. Sorry, arm dran, wer das nicht versteht.
Die Schnipsel in meinem vorletzten Post enthalten kein SelectionChange mehr.
Das Beste kommt immer erst zum Schluss.
(02.09.2021, 18:30)schauan schrieb: [ -> ]Hallöchen,
Hast Du nun mal versucht, Kommentare mit einem eigenen Makro einzufügen, zu bearbeiten und zu löschen?
Immer mit der Ruhe. Zuerst einmal werde ich mich damit beschäftigen, ob das mit irgendwelchen nicht unwesentlichen Nachteilen verbunden ist und ob ich diese Lösung überhaupt noch brauche.
Und jetzt muss ich die Ruhezeiten im Homeoffice beachten.