Excel Kommentar mit Format, Farbe, größe des Rahmens in alle Tabellenblätter kopieren

[jagga007]

Hallo-Forum,

ich habe eine Excel-Datei mit 12 Tabellenblättern vom Jan-Dez.

Ich würde gerne den Kommentar in die anderen Tabellenblätter an die gleiche Stelle kopieren und das mit VBA lösen.
das einfache kopieren hätte ich mit VBA gelöst, aber mein Kommentar hat eine bestimmte Fenstergröße einen Rahmen und einen Fülleffekt.

Und da habe ich meine Probleme. Ich hätte da ein mögliches Beispiel im Web gefunden (siehe Code am Ende) diese will aber beim Shape.Copy nicht weiter machen und bringt den Fehler 1004.

Blattschutz ist aus, Bereichs bzw. Tabellenname ist richtig und beim Debuggen auch kein Fehler.

Vielleicht kann mir hier einer helfen?

Mit freundlichen Gruß
Rudolf

Code:

Sub KommentarMitFormatInAlleBlaetterKopieren()
    Dim wsQuelle As Worksheet
    Dim wsZiel As Worksheet
    Dim adr As String
    Dim cmtShape As Shape
    Dim neueShape As Shape
   
    Call ActiveSheet.Unprotect(PASS_WORD)

    ' === Einstellungen ===
    Set wsQuelle = ThisWorkbook.Sheets("Jan")    ' Quellblatt anpassen
    adr = "O9"                                   ' Zelle mit Kommentar anpassen

    ' Prüfen, ob Kommentar vorhanden ist
    If wsQuelle.Range(adr).Comment Is Nothing Then
        MsgBox "In " & wsQuelle.Name & "!" & adr & " ist kein Kommentar vorhanden.", vbExclamation
        Exit Sub
    End If

    ' Shape-Objekt des Kommentars holen
    Set cmtShape = wsQuelle.Shapes(wsQuelle.Range(adr).Comment.Shape.Name)

    Application.ScreenUpdating = False

    ' Über alle Blätter iterieren
    For Each wsZiel In ThisWorkbook.Worksheets
        If wsZiel.Name <> wsQuelle.Name And wsZiel.Name <> "Auslöse" And wsZiel.Name <> "Master" Then
            ' Falls in Zielzelle schon ein Kommentar ist, löschen
            If Not wsZiel.Range(adr).Comment Is Nothing Then
                wsZiel.Range(adr).Comment.Delete
            End If

            ' Kommentartext anlegen (damit Shape existiert)
            wsZiel.Range(adr).AddComment Text:=wsQuelle.Range(adr).Comment.Text

            ' Shape im Zielblatt holen
            Set neueShape = wsZiel.Shapes(wsZiel.Range(adr).Comment.Shape.Name)

            ' Formatierung vom Quell-Shape kopieren
            cmtShape.Copy
            neueShape.PasteSpecial

            ' Das eingefügte Shape ist eine Kopie – wir müssen es der Zelle zuordnen
            ' Daher löschen wir das automatisch erzeugte Shape und benennen das neue um
            neueShape.Delete
            wsZiel.Shapes(wsZiel.Shapes.Count).Name = wsZiel.Range(adr).Comment.Shape.Name
        End If
    Next wsZiel

    Application.ScreenUpdating = True
    MsgBox "Kommentar mit kompletter Formatierung in alle Blätter kopiert.", vbInformation
   
    Call BlattschutzalleAusserAn

End Sub

[shift-del]

Moin

Siehe auch dort:
https://www.mrexcel.com/board/threads/ex...r.1277732/

PS:
Dort wurde der VBA-Code 'deutsch übersetzt'.

Code:

Rufen Sie BlattschutzalleAusserAn an

Untertitel beenden

[RPP63]

Wie dammalz, Excel 5.0, lokalisierte Version …

Code:

Für jedes wsZiel In diesem Arbeitsbuch. Arbeitsblätter
Wenn wsZiel.Name <> wsQuelle.Name und wsZiel.Name <> "Auslöse" und wsZiel.Name <> "Master" dann
            ' Falls in Zielzelle schon ein Kommentar ist, löschen

SchmeißMichWeg

[Egon12]

Hallo,

hier mal ein Beispiel auf die Schnelle wie man nur die Kommentare übertragen kann.
Falls du es nicht schaffst dies deinen Vorstellungen anzupassen, hilft Datei anonymisiert mit brauchbarem Inhalt hochladen.

  Kommentar kopieren.xlsm (Größe: 16,99 KB / Downloads: 6)

Gruß Uwe

[HKindler]

Hi,

ein einfaches

Code:

Quelle.Copy
Ziel.PasteSpecial xlPasteComments

funktioniert bei dir nicht?

[Egon12]

doch. Es führen viele Wege nach Rom.

Gruß Uwe

[HKindler]

Hi Uwe,

ich meinte nicht dich, sondern jagga007.

[Egon12]

Alles gut. 

Gruß Uwe