De lune Rouse - Imprimer un commentaire

Bonjour,

Ci-dessous un code qui devrait répondre à votre problème.

Copiez le code dans un module standard de votre classeur
et lancez une des 2 macros.

MACRO RetireNomCommentaires
MIEUX VAUT TRAVAILLER SUR UNE COPIE DE LA FEUILLE
Comme son nom l'indique efface le nom d'utilisateur qui vous
sera demandé. Cela n'effacera que le nom se trouvant
en tête du commentaire. Autrement dit si ce nom est
présent dans le texte du commentaire il ne sera pas effacé.

MACRO FormatageCommentaire
Ici, pas de problème de copie de feuille puisque cette macro en
construit une automatiquement. Je n'ai pas été plus loin pour
mettre cette macro à l'abri de tout bug éventuel car ça m'a déjà
pas mal pris la tête.
Vous pourrez constater qu'en cas de plusieurs commentaires
sur une même ligne cette dernière aura tendance à grandir.
Je vous laisse le soin de retoucher à la main les hauteurs de lignes
malencontreuses.

**********************************
Option Explicit
'___________________________________
Sub FormatageCommentaire()
Dim colVBreak%
Dim C As Comment
Dim S As Shape
Dim R As Range
Dim A$
'---- On sort si absence de commentaires ----
If ActiveSheet.Comments.Count = 0 Then Exit Sub
'---- Crée une copie de la feuille ----
Sheets(ActiveSheet.Name).Copy _
After:=Sheets(ActiveSheet.Name)
'---- Mise en page avec les commentaires ----
ActiveSheet.PageSetup.PrintComments = xlPrintInPlace
'---- Aligne les commentaires sur les cellules ----
Application.ScreenUpdating = False
For Each C In ActiveSheet.Comments
Set R = Columns(C.Parent.Column)
C.Shape.Left = R.Width + R.Left
Next C
'---- Si sur plusieurs pages ----
colVBreak% = 256
On Error Resume Next
colVBreak% = ActiveSheet.VPageBreaks(1) _
.Location.Column - 1
On Error GoTo 0
'#### GRANDE BOUCLE ####
On Error GoTo Erreur
For Each C In ActiveSheet.Comments
Set R = Rows(C.Parent.Row)
Set S = C.Shape
S.Select
With Selection
.AutoSize = True
.AutoSize = False
If .BottomRightCell.Column > colVBreak% Then
Do Until .BottomRightCell.Column <= _
colVBreak% + (colVBreak% * _
(C.Parent.Column colVBreak%))
S.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
S.ScaleHeight 2.5, msoFalse, msoScaleFromTopLeft
If .Height >= 200 Then
.Height = 200 'limite
End If
Loop
End If
.Top = R.Top
If R.Height + .Height > 409 Then
R.RowHeight = 409 'limite
Else
R.RowHeight = R.Height + .Height
End If
End With
Next C
[a1].Select
'---- Pseudo traitement d'erreur ----
Erreur:
Application.ScreenUpdating = True
End Sub
'___________________________________
Sub RetireNomCommentaires()
Dim C As Comment
Dim reponse
Dim A$
Dim bool As Boolean
On Error GoTo Erreur:
reponse = InputBox(prompt:= _
IL EST PRUDENT DE TRAVAILLER & _
SUR UNE COPIE DE VOTRE FEUILLE & _
vbCrLf & vbCrLf & _
Taper le nom à effacer des commentaires., _
Title:= _
Effacer le nom d'utilisateur des commentaires)
If reponse = "" Then Exit Sub
Application.ScreenUpdating = False
If ActiveSheet.Comments.Count = _
0 Then Exit Sub
For Each C In ActiveSheet.Comments
A$ = C.Text
If UCase(Left(A$, Len(reponse))) = _
UCase(reponse) Then
bool = True
A$ = Mid(A$, Len(reponse) + 1)
If Left(A$, 2) = ":" & Chr(10) Then
A$ = Mid(A$, 3)
End If
C.Text Text:=A$
End If
Next C
If Not bool Then
MsgBox prompt:="Le nom " & _
reponse & " est introuvable.", _
Buttons:=vbOKOnly
End If
'---- Pseudo traitement d'erreur ----
Erreur:
Application.ScreenUpdating = True
End Sub
**********************************

En espérant que ça marche aussi bien chez vous que chez moi.

Cordialement.

PMO
Patrick Morange

Bonjour,

Soit une cellule A1, je souhaite imprimer par une macro le contenu de la
cellule et de son commentaire s'il existe.

Une fois ce formidable travail réalisé il me serai agréable d'imprimer la
même chose pour les 3000 premières cellules de la colonne A.

Je cale sur deux points :

1 - Comment supprimer dans l'impression du commentaire le nom
d'utilisateur qui est écrit dans la commentaire.


2 - Comment, si la largeur d'impréssion de la colonne A est fixe, augmenter
la hauteur d'impression en fonction du texte contenu dans le commentaire


J'ai fait cela

Sub Macro2()

' Macro enregistrée le 14/02/2005 par Wolfgang Amadeus MOZART
'
Range("D5").Select
ActiveCell.FormulaR1C1 = "=RC[1]&"" ""&RC[2]&"" """
Range("E5").Select
Range("E5").Comment.Text Text:="Wolfgang Amadeus MOZART:" & Chr(10) &
" Les aminoacides sont polymérisés à l’intérieur d’une chaîne
polypeptide sur les ribosomes de la cellule D1 poids
moléculaire : 3512"

Range("D5").Select
ActiveCell.FormulaR1C1 = _
"=RC[1]&"" ""&RC[2]&"" ""&""Les aminoacides sont polymérisés à
l’intérieur d’une chaîne polypeptide sur les ribosomes de la cellule D1
poids moléculaire : 3512""&"" ""&RC[6]"

Range("D6").Select
End Sub

Merci de vos suggestion


Une petit bonjour à ZAZA

Lune Rousse