Sub Formeln_AlsKommentar()
'******************************************************
->Für jede Zelle mit Formel im selektierten Bereich
->des aktiven Blattes wird ein sichtbarer Kommentar
-> erzeugt. Der Kommentar enthält die Formel
'******************************************************
->Beschreibung des Hilfsblattes
Const c_SP_zeile As Long = 1
Const c_SP_zeile_Text As String = Zeile
Const c_SP_spalte As Long = 2
Const c_SP_spalte_Text As String = Spalte
Const c_SP_formel As Long = 3
Const c_SP_formel_Text As String = Formel
Const c_SP_kommentar As Long = 4
Const c_SP_kommentar_Text As String = Kvorhanden
Const c_SP_breite As Long = 5
Const c_SP_breite_Text As String = KBreite
Const c_SP_hoehe As Long = 6
Const c_SP_hoehe_Text As String = KHöhe
->Anzahl genutzter Spalten
Const c_SP_Anz = 6
->FormelKommentar
Const c_Kom_FontName = Arial
Const c_Kom_FontSize = 9
Dim ws As Worksheet, ws2 As Worksheet, r As Range, Zelle As Range
Dim l_zeile As Long, s_tmp As String, x As Long, l_spalte As Long
Dim l_Kom_heightInPkt As Double, l_Kom_widthInPkt As Double
Dim Kommentar As Comment, b_ueberspringen As Boolean
Dim l_aktz As Long, l_aktsp As Long, ret As Integer
If ActiveSheet.Type <> xlWorksheet Then
MsgBox (aktives Blatt ist keine Tabelle!): Exit Sub
End If
If TypeName(Selection) <> Range Then
MsgBox (Es ist kein Zellbereich markiert): Exit Sub
End If
Set ws = ActiveSheet
Set r = Selection
->falls ganzes Blatt selektiert ist
->nur den benutzten Bereich untersuchen
If (ws.Rows.Count = r.Rows.Count) And _
(ws.Columns.Count = r.Columns.Count) Then
Set r = ws.UsedRange
End If
->Bildschirm-Update ausschalten
Application.ScreenUpdating = False
->neues Blatt einrichten
Set ws2 = Worksheets.Add
->Formatierung des neuen Blattes -> Text
ws2.Cells.NumberFormat = @
ws.Columns(c_SP_hoehe).NumberFormat = 0.0
ws.Columns(c_SP_breite).NumberFormat = 0.0
->Überschriften
l_zeile = 1
Call SPUeberschrSetzen(ws2, l_zeile, c_SP_zeile, c_SP_zeile_Text)
Call SPUeberschrSetzen(ws2, l_zeile, c_SP_spalte, c_SP_spalte_Text)
Call SPUeberschrSetzen(ws2, l_zeile, c_SP_formel, c_SP_formel_Text)
Call SPUeberschrSetzen(ws2, l_zeile, c_SP_kommentar, c_SP_kommentar_Text)
Call SPUeberschrSetzen(ws2, l_zeile, c_SP_breite, c_SP_breite_Text)
Call SPUeberschrSetzen(ws2, l_zeile, c_SP_hoehe, c_SP_hoehe_Text)
->Formeln suchen und auf neuem Blatt ausgeben
For Each Zelle In r
If Left(Zelle.Formula, 1) = = Then
l_zeile = l_zeile + 1
Application.StatusBar = Anz. bereits gefundener Formeln: & l_zeile
ws2.Cells(l_zeile, c_SP_zeile).Value = Zelle.Row
ws2.Cells(l_zeile, c_SP_spalte).Value = Zelle.Column
ws2.Cells(l_zeile, c_SP_formel).Value = & Zelle.Formula
->prüfen, ob bereits ein Kommentar vorhanden ist
If Not Zelle.Comment Is Nothing Then
ws2.Cells(l_zeile, c_SP_kommentar).Value = ja
End If
End If
Next
->Spaltenbreite optimieren
For x = 1 To c_SP_Anz: ws2.Columns(x).AutoFit: Next
->Spalten nach Zeile, Spalte sortieren
ws2.Cells.Sort _
Key1:=ws2.Range(ws2.Cells(1, c_SP_zeile), ws2.Cells(1, c_SP_zeile)), _
Key2:=ws2.Range(ws2.Cells(1, c_SP_spalte), ws2.Cells(1, c_SP_spalte)), _
Header:=xlYes, Orientation:=xlTopToBottom
->keine Formel gefunden
If l_zeile = 1 Then
MsgBox (Es ist keine Formel im selektierten Bereich enthalten.)
Else
->Kommentarhöhe bestimmen
With ws2.Cells(l_zeile + 1, c_SP_Anz + 1)
.Font.Name = c_Kom_FontName
.Font.Size = c_Kom_FontSize
.Value = Üg
End With
ws2.Rows(l_zeile + 1).AutoFit
l_Kom_heightInPkt = ws2.Rows(l_zeile + 1).Height
->Kommentarbreite bestimmen
For x = 2 To l_zeile
Application.StatusBar = Kommentar-Breite bestimmen ( & x & / & l_zeile & )
ws2.Cells(l_zeile + 1, c_SP_Anz + 1).Value = _
ws2.Cells(x, c_SP_formel).Value
ws2.Columns(c_SP_Anz + 1).AutoFit
l_Kom_widthInPkt = ws2.Columns(c_SP_Anz + 1).Width
ws2.Cells(x, c_SP_hoehe).Value = l_Kom_heightInPkt
ws2.Cells(x, c_SP_breite).Value = l_Kom_widthInPkt
Next
->alle Kommentare erzeugen
->wenn bereits Kommentar vorhanden, Abfrage:->überschreiben?'
For x = 2 To l_zeile
Application.StatusBar = Kommentar einfügen ( & x & / & l_zeile & )
b_ueberspringen = False
l_aktz = ws2.Cells(x, c_SP_zeile).Value
l_aktsp = ws2.Cells(x, c_SP_spalte).Value
->bereits ein Kommentar vorhanden -> Abfrage auf überschreiben
If ws2.Cells(x, c_SP_kommentar).Value <> Then
ws.Activate
ws.Cells(l_aktz, l_aktsp).Select
ret = MsgBox( _
In dieser Zelle ist bereits ein Kommentar vorhanden. & vbLf & _
Soll der Kommentar überschrieben werden ?, _
vbYesNoCancel + vbQuestion + vbDefaultButton2)
If ret = vbNo Then
b_ueberspringen = True
ElseIf ret = vbCancel Then
GoTo aufraeumen
Else
->Überschreiben -> Kommentar vorher löschen
ws.Cells(l_aktz, l_aktsp).ClearComments
End If
End If
If Not b_ueberspringen Then
->Kommentar anlegen und Formatieren
Set Kommentar = ws.Cells(l_aktz, l_aktsp).AddComment
Kommentar.Visible = True
s_tmp = ws2.Cells(x, c_SP_formel).Value
->(Leerzeichen vor Formel entfernen)
Kommentar.Text Text:=Right(s_tmp, Len(s_tmp) - 1)
Kommentar.Shape.Select
With Selection: .Font.Name = c_Kom_FontName: .Font.Size = c_Kom_FontSize: End With
With Kommentar.Shape:
.TextFrame.HorizontalAlignment = xlHAlignLeft
.Height = ws2.Cells(x, c_SP_hoehe).Value: .Width = ws2.Cells(x, c_SP_breite).Value
.Locked = False: .Placement = xlMove
End With
End If
Next
End If
aufraeumen:
->aufraeumen
Application.DisplayAlerts = False
ws2.Delete
Application.DisplayAlerts = True
On Error Resume Next
Set ws = Nothing: Set ws2 = Nothing: Set Kommentar = Nothing: Set r = Nothing: Set Zelle = Nothing
On Error GoTo 0
Application.ScreenUpdating = True
Application.StatusBar =
End Sub
Private Function SPUeberschrSetzen(wsx As Worksheet, _
l_zeile As Long, l_spalte As Long, s_text As String)
With wsx.Cells(l_zeile, l_spalte)
.Value = s_text: .Font.Bold = True
End With
End Function
