|
Avec cette procédure, au lancement d'un fichier, 3 nouvelles options sont ajoutées au menu Cell (obtenu par un clic droit sur une cellule) :
- Répertorier Commentaires Fichier actif
- Répertorier Commentaires Feuille active
- Répertorier Commentaires Colonne active
Ainsi, selon l'option choisie, lorsqu'il y a des commentaires dans les cellules ceux-ci sont répertoriés et listés sur une nouvelle feuille Attention la procédure suivante est longue mais bougrement efficace...
'********************************
'partie à coller dans Thisworbook
'********************************
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
SupprimeControles
End Sub
Private Sub Workbook_Open()
Initialise
End Sub
'**************************************
'partie à coller dans un premier module
'**************************************
Option Explicit
Option Private Module
'Thierry Pourtier : xlti@wanadoo.fr
'octobre 03
Enum eTypeCmnt
Fichier
Feuille
Colonne
End Enum
Dim WbkComnts As Workbook, ActiveWbk As Workbook
Dim Ws As Worksheet
Public Type TComnt
Texte As String
Feuille As String
Colonne As String
Plage As String
End Type
Dim ComntsClasseur() As TComnt
Dim NbComnts As Long
Dim NbFeuilles As Long
Dim Feuilles
Private Function CreeWbkComnts() As String
Dim Ws As Worksheet, Cel As Range
On Error GoTo erreur
Set WbkComnts = Workbooks.Add(xlWBATWorksheet)
With WbkComnts
With .Worksheets(1)
.Name = "Liste des commentaires"
With .Range("A1:C1")
.Merge
.HorizontalAlignment = xlCenter
.Value = "Liste des commentaires du fichier " & ActiveWbk.Name
End With
With .Range("A2:C2")
.Merge
.HorizontalAlignment = xlCenter
End With
With .Range("A3")
.Value = "Feuille"
'.Offset(0, 1) = "Colonne"
.Offset(0, 1) = "Emplacement"
.Offset(0, 2) = "Commentaire"
End With
End With
End With
Exit Function
erreur:
CreeWbkComnts = "à la création du fichier liste des Commentaires"
End Function
Private Function NomColonne(ByVal Cel As Range) As String
With Cel
Set Cel = .Offset(-.Row + 1, 0)
End With
If Cel.Value <> "" Then NomColonne = Cel Else _
NomColonne = Cel.Offset(1, 0)
End Function
Private Sub Commentaires(Feuille As Worksheet, Optional Colonne As Long)
Dim Comnt As Comment, PlageComnt As Range
On Error Resume Next
For Each Comnt In Feuille.Comments
If Colonne = 0 Or Comnt.Parent.Column = Colonne Then
NbComnts = NbComnts + 1
ReDim Preserve ComntsClasseur(1 To NbComnts)
With ComntsClasseur(NbComnts)
.Texte = Comnt.Text
Set PlageComnt = Comnt.Parent
.Plage = PlageComnt.Address
.Feuille = PlageComnt.Worksheet.Name
.Colonne = NomColonne(PlageComnt)
End With
End If
Next Comnt
End Sub
Private Function ListeCommentaires(Etendue As eTypeCmnt) As String
Dim Ws As Worksheet
On Error GoTo erreur
NbComnts = 0
Select Case Etendue
Case Fichier
For Each Ws In ActiveWbk.Worksheets
Commentaires Ws
Next Ws
Case Feuille
Commentaires ActiveSheet
Case Colonne
Commentaires ActiveSheet, ActiveCell.Column
End Select
Exit Function
erreur:
ListeCommentaires = "au recensement des commentaires"
End Function
Private Sub TriPlage(Plage As Range)
Plage.Sort Key1:=Plage.Cells(1, 1), Order1:=xlAscending, _
Key2:=Plage.Cells(1, 2), Order2:=xlAscending, Header:=xlNo, _
MatchCase:=False
End Sub
Private Function EcritCommentaires() As String
Dim CelDeb As Range, Cel As Range, Boucle As Long
Dim Plage As Range
On Error GoTo erreur
With WbkComnts
With .Worksheets(1)
Set Cel = .Range("A65536").End(xlUp).Offset(1, 0)
End With
End With
Set CelDeb = Cel
For Boucle = 1 To NbComnts
With ComntsClasseur(Boucle)
Cel = .Feuille
'Cel.Offset(0, 1) = .Colonne
Cel.Offset(0, 1) = .Plage
Cel.Offset(0, 2) = .Texte
Set Cel = Cel.Offset(1, 0)
End With
Next Boucle
Set Plage = Range(CelDeb, Cel).Resize(, 3)
If Plage.Rows.Count > 1 Then TriPlage Plage
Exit Function
erreur:
EcritCommentaires = "à l'écriture de la liste des commentaires"
End Function
Private Function MetEnForme() As String
Dim Ws As Worksheet, Plage As Range, Colonne As Range, Bord
Dim NbLgn As Long, Cel As Range
Dim Boucle As Long, Couleur As Long
On Error GoTo erreur
With WbkComnts
Set Plage = Worksheets(1).UsedRange
End With
With Plage
For Each Colonne In .Columns
With Colonne
.VerticalAlignment = xlCenter
.WrapText = IIf(.Column < 3, False, True)
.ShrinkToFit = False
.EntireColumn.AutoFit
End With
Next Colonne
For Each Bord In Array(xlEdgeTop, xlEdgeBottom, xlEdgeLeft, xlEdgeRight, _
xlInsideVertical, xlInsideHorizontal)
With .Borders(Bord)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Next Bord
'1ère ligne en jaune
With .Rows(1)
.Interior.ColorIndex = 19
.Font.Size = 12
.Font.Bold = True
.Font.ColorIndex = 23
End With
'2ème ligne
With .Rows(2)
.Interior.ColorIndex = 35
.Font.Bold = True
.Font.ColorIndex = 23
End With
With .Rows(3)
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 40
.Font.Bold = True
.Font.ColorIndex = 5
End With
Columns("A:B").ColumnWidth = 22
Columns("C:C").ColumnWidth = 60
Set Cel = Range(.Cells(4, 1), .Cells(.Rows.Count, 3))
With Cel
.Columns(1).HorizontalAlignment = xlCenter
.Columns(2).HorizontalAlignment = xlCenter
.Rows.AutoFit
.Interior.ColorIndex = 34
.Columns(3).Interior.ColorIndex = 37
End With
End With
Exit Function
erreur:
MetEnForme = "à la mise en forme du fichier liste des commentaires"
End Function
Sub RecenseCommentaires(Etendue As eTypeCmnt)
Dim Boucle As Long, Ws As Worksheet, Plage As Range
Dim MsgErreur As String
On Error Resume Next
Application.ScreenUpdating = False
Set ActiveWbk = Nothing
Set ActiveWbk = ActiveWorkbook
If ActiveWbk Is Nothing Then Exit Sub
Select Case Etendue
Case Feuille
Set Ws = ActiveSheet
If Ws Is Nothing Then Exit Sub
Case Colonne
Set Plage = ActiveCell
If Plage Is Nothing Then Exit Sub
End Select
On Error GoTo erreur
'recense tous les Comnts du fichier
MsgErreur = ListeCommentaires(Etendue)
If MsgErreur <> "" Then GoTo erreur
If NbComnts = 0 Then
MsgBox "Le fichier actif ne contient aucun commentaire", , "ListeComntsTi"
Else
'crée le fichier recensant les commentaires
MsgErreur = CreeWbkComnts
If MsgErreur <> "" Then GoTo erreur
'écrit la liste des commentaires par feuille dans le fichier
MsgErreur = EcritCommentaires
If MsgErreur <> "" Then GoTo erreur
'mise en forme finale
MsgErreur = MetEnForme
If MsgErreur <> "" Then GoTo erreur
Application.ScreenUpdating = True
End If
Exit Sub
erreur:
Application.ScreenUpdating = True
MsgBox "Erreur " & MsgErreur, , "ListeComntsTi"
End Sub
'***************************************
'partie à coller dans un deuxième module
'***************************************
Option Explicit
Option Private Module
'Thierry Pourtier : xlti@wanadoo.fr
'octobre 03
Const MyTag As String = "MnsComnt"
Sub Initialise(Optional dum As Byte)
Dim LBar As CommandBar, Ctrl As CommandBarControl
Dim Cel As Range
On Error Resume Next
SupprimeControles
Set LBar = Application.CommandBars("cell")
With LBar.Controls _
.Add(Type:=msoControlButton, before:=1, temporary:=True)
.Caption = "Répertorier Commentaires Fichier actif"
.OnAction = "CommFichier"
.Tag = MyTag
End With
With LBar.Controls _
.Add(Type:=msoControlButton, before:=2, temporary:=True)
.Caption = "Répertorier Commentaires Feuille active"
.OnAction = "CommFeuille"
.Tag = MyTag
End With
With LBar.Controls _
.Add(Type:=msoControlButton, before:=3, temporary:=True)
.Caption = "Répertorier Commentaires Colonne active"
.OnAction = "CommColonne"
.Tag = MyTag
End With
End Sub
Sub SupprimeControles(Optional dum As Byte)
Dim Ctrl As CommandBarControl
On Error Resume Next
For Each Ctrl In Application.CommandBars("cell").Controls
If Ctrl.Tag = MyTag Then Ctrl.Delete
Next Ctrl
End Sub
Private Sub CommFichier()
RecenseCommentaires Fichier
End Sub
Private Sub CommFeuille()
RecenseCommentaires Feuille
End Sub
Private Sub commcolonne()
RecenseCommentaires Colonne
End Sub
Date de création : 24/05/2005 - 19:20
Dernière modification : 25/05/2005 - 21:24
Catégorie : Commentaires
Page lue 2903 fois
 Prévisualiser la page
 Imprimer la page
|
|
OOo
OOo
Membres: 1661
Membre en ligne: 0
Anonymes en ligne: 27
Haut 
