Récupérer les commentaires de certaines colonnes seulement [VBA Excel 2000]

Bonjour,
Essaie :
Private Sub Worksheet_Activate()
Dim rg As Range
Set f = Sheets("Feuil1")
Set rg =
f.Range("k:k,u:u,ae:ae,ao:ao,ay:ay,bi:bi,bs:bs,cc:cc,cm:cm,cw:cw,dg:dg,dq:dq")
ligne = 2
For Each c In f.Cells.SpecialCells(xlCellTypeComments)
If Not Intersect(rg, c) Is Nothing Then
adr = c.Address
Cells(ligne, 1) = adr
'adresse de al cellule contenant un commentaire
Cells(ligne, 2) = f.Cells(c.Row, 3)
'nom
Cells(ligne, 3) = c.Value
'contenu de la cellule
temp = c.Text
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
'contenu du commentaire
ligne = ligne + 1
End If
Next c
End Sub
Cordialement.
Daniel

Bonjour à tous

Grâce à un code venant de chez J Boisgontier je récupère *tous* les
commentaires d'une feuille (ainsi que d'autres données).

Mais je souhaiterais ne récupérer que les commentaires venant de certaines
colonnes, par exemple ici celles mises en array :
ArCol = Array("k:k", "u:u", "ae:ae", "ao:ao", "ay:ay", "bi:bi", "bs:bs", _
"cc:cc", "cm:cm", "cw:cw", "dg:dg", "dq:dq")

Comment adapter le code de la macro, svp?
'********************
Private Sub Worksheet_Activate()
Set f = Sheets("Feuil1")
ligne = 2
For Each C In f.Comments
adr = C.Parent.Address
Cells(ligne, 1) = adr
'adresse de al cellule contenant un commentaire
Cells(ligne, 2) = f.Cells(Range(adr).Row, 3)
'nom
Cells(ligne, 3) = f.Range(adr)
'contenu de la cellule
temp = C.Text
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
'contenu du commentaire
ligne = ligne + 1
Next C
End Sub
'********************
Merci
@+
J@@

Bonjour Daniel
Merci pour l'aide, cela fonctionne bien, mais :
- à la ligne If Not Intersect(rg, C) Is Nothing Then

cela me lance le code événementiel de traçage de rectangle rouge de
Gaëtan Mourmant polykromy existant dans la feuil1, code lancé de la
façon suivante :

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
.....

de plus ce code me protège la feuille, ce que je ne souhaite pas.

A ton avis, comment éviter de lancer cette macro événementielle ?

Merci pour l'aide.
@+
J@@


Le 31/05/2011 21:27, DanielCo a écrit :

Bonjour,
Essaie :
Private Sub Worksheet_Activate()
Dim rg As Range
Set f = Sheets("Feuil1")
Set rg > f.Range("k:k,u:u,ae:ae,ao:ao,ay:ay,bi:bi,bs:bs,cc:cc,cm:cm,cw:cw,dg:dg,dq:dq")

ligne = 2
For Each c In f.Cells.SpecialCells(xlCellTypeComments)
If Not Intersect(rg, c) Is Nothing Then
adr = c.Address
Cells(ligne, 1) = adr
'adresse de al cellule contenant un commentaire
Cells(ligne, 2) = f.Cells(c.Row, 3)
'nom
Cells(ligne, 3) = c.Value
'contenu de la cellule
temp = c.Text
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
'contenu du commentaire
ligne = ligne + 1
End If
Next c
End Sub
Cordialement.
Daniel

Bonjour à tous

Grâce à un code venant de chez J Boisgontier je récupère *tous* les
commentaires d'une feuille (ainsi que d'autres données).

Mais je souhaiterais ne récupérer que les commentaires venant de
certaines colonnes, par exemple ici celles mises en array :
ArCol = Array("k:k", "u:u", "ae:ae", "ao:ao", "ay:ay", "bi:bi",
"bs:bs", _
"cc:cc", "cm:cm", "cw:cw", "dg:dg", "dq:dq")

Comment adapter le code de la macro, svp?
'********************
Private Sub Worksheet_Activate()
Set f = Sheets("Feuil1")
ligne = 2
For Each C In f.Comments
adr = C.Parent.Address
Cells(ligne, 1) = adr
'adresse de al cellule contenant un commentaire
Cells(ligne, 2) = f.Cells(Range(adr).Row, 3)
'nom
Cells(ligne, 3) = f.Range(adr)
'contenu de la cellule
temp = C.Text
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
'contenu du commentaire
ligne = ligne + 1
Next C
End Sub
'********************
Merci
@+
J@@

Ajoute la ligne :
Application.EnableEvents = False
en début de macro et la ligne suivante
Application.EnableEvents = True
en fin de macro
Daniel

Bonjour Daniel
Merci pour l'aide, cela fonctionne bien, mais :
- à la ligne If Not Intersect(rg, C) Is Nothing Then

cela me lance le code événementiel de traçage de rectangle rouge de Gaëtan
Mourmant polykromy existant dans la feuil1, code lancé de la façon suivante
:

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
.....

de plus ce code me protège la feuille, ce que je ne souhaite pas.

A ton avis, comment éviter de lancer cette macro événementielle ?

Merci pour l'aide.
@+
J@@

Re bonjour

Eh non, il y a autre chose qui coince :

les commentaires n'apparaissent pas, mais à la place on a une
réplication partielle de la donnée précédente (Cells(ligne, 3) = c.Value).
exemple :
contenu cellule //// commentaire affiché /// vrai com
101010 1010 azqs
159753 59753 kkkkkkkk
p aucune donnée 123456

Une idée, stp ?
Merci
@+
J@@


Le 31/05/2011 21:27, DanielCo a écrit :

Bonjour,
Essaie :
Private Sub Worksheet_Activate()
Dim rg As Range
Set f = Sheets("Feuil1")
Set rg > f.Range("k:k,u:u,ae:ae,ao:ao,ay:ay,bi:bi,bs:bs,cc:cc,cm:cm,cw:cw,dg:dg,dq:dq")

ligne = 2
For Each c In f.Cells.SpecialCells(xlCellTypeComments)
If Not Intersect(rg, c) Is Nothing Then
adr = c.Address
Cells(ligne, 1) = adr
'adresse de al cellule contenant un commentaire
Cells(ligne, 2) = f.Cells(c.Row, 3)
'nom
Cells(ligne, 3) = c.Value
'contenu de la cellule
temp = c.Text
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
'contenu du commentaire
ligne = ligne + 1
End If
Next c
End Sub
Cordialement.
Daniel

Bonjour à tous

Grâce à un code venant de chez J Boisgontier je récupère *tous* les
commentaires d'une feuille (ainsi que d'autres données).

Mais je souhaiterais ne récupérer que les commentaires venant de
certaines colonnes, par exemple ici celles mises en array :
ArCol = Array("k:k", "u:u", "ae:ae", "ao:ao", "ay:ay", "bi:bi",
"bs:bs", _
"cc:cc", "cm:cm", "cw:cw", "dg:dg", "dq:dq")

Comment adapter le code de la macro, svp?
'********************
Private Sub Worksheet_Activate()
Set f = Sheets("Feuil1")
ligne = 2
For Each C In f.Comments
adr = C.Parent.Address
Cells(ligne, 1) = adr
'adresse de al cellule contenant un commentaire
Cells(ligne, 2) = f.Cells(Range(adr).Row, 3)
'nom
Cells(ligne, 3) = f.Range(adr)
'contenu de la cellule
temp = C.Text
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
'contenu du commentaire
ligne = ligne + 1
Next C
End Sub
'********************
Merci
@+
J@@

L'affaire des rectangles est réglée avec enableevents,
mais les commentaires ne sont pas récupérés
Il y a qq chose qui coince...
Que faut-il modifier, stp ?
Merci
J@@

Le 31/05/2011 22:09, DanielCo a écrit :

Ajoute la ligne :
Application.EnableEvents = False
en début de macro et la ligne suivante
Application.EnableEvents = True
en fin de macro
Daniel

Bonjour Daniel
Merci pour l'aide, cela fonctionne bien, mais :
- à la ligne If Not Intersect(rg, C) Is Nothing Then

cela me lance le code événementiel de traçage de rectangle rouge de
Gaëtan Mourmant polykromy existant dans la feuil1, code lancé de la
façon suivante :

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
.....

de plus ce code me protège la feuille, ce que je ne souhaite pas.

A ton avis, comment éviter de lancer cette macro événementielle ?

Merci pour l'aide.
@+
J@@

Au temps pour moi :

Private Sub Worksheet_Activate()
Dim rg As Range, c As Range
Application.EnableEvents = False
Set f = Sheets("Feuil1")
Set rg =
f.Range("k:k,u:u,ae:ae,ao:ao,ay:ay,bi:bi,bs:bs,cc:cc,cm:cm,cw:cw,dg:dg,dq:dq")
ligne = 2
For Each c In f.Cells.SpecialCells(xlCellTypeComments)
If Not Intersect(rg, c) Is Nothing Then
adr = c.Address
Cells(ligne, 1) = adr
'adresse de al cellule contenant un commentaire
Cells(ligne, 2) = f.Cells(c.Row, 3)
'nom
Cells(ligne, 3) = c.Value
'contenu de la cellule
temp = c.Comment.Text
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
'contenu du commentaire
ligne = ligne + 1
End If
Next c
Application.EnableEvents = True
End Sub

Daniel

L'affaire des rectangles est réglée avec enableevents,
mais les commentaires ne sont pas récupérés
Il y a qq chose qui coince...
Que faut-il modifier, stp ?
Merci
J@@

Le 31/05/2011 22:09, DanielCo a écrit :

Ajoute la ligne :
Application.EnableEvents = False
en début de macro et la ligne suivante
Application.EnableEvents = True
en fin de macro
Daniel

Bonjour Daniel
Merci pour l'aide, cela fonctionne bien, mais :
- à la ligne If Not Intersect(rg, C) Is Nothing Then

cela me lance le code événementiel de traçage de rectangle rouge de
Gaëtan Mourmant polykromy existant dans la feuil1, code lancé de la
façon suivante :

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
.....

de plus ce code me protège la feuille, ce que je ne souhaite pas.

A ton avis, comment éviter de lancer cette macro événementielle ?

Merci pour l'aide.
@+
J@@

Parfait Daniel

juste une petite modification car je perdais le 1er caractère de gauche
du commentaire, une erreur de mon code initial :
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 1) 'au lieu de + 2

Encore merci.
Tout va bien.
@+
J@@


Le 31/05/2011 22:35, DanielCo a écrit :

Au temps pour moi :

Private Sub Worksheet_Activate()
Dim rg As Range, c As Range
Application.EnableEvents = False
Set f = Sheets("Feuil1")
Set rg > f.Range("k:k,u:u,ae:ae,ao:ao,ay:ay,bi:bi,bs:bs,cc:cc,cm:cm,cw:cw,dg:dg,dq:dq")

ligne = 2
For Each c In f.Cells.SpecialCells(xlCellTypeComments)
If Not Intersect(rg, c) Is Nothing Then
adr = c.Address
Cells(ligne, 1) = adr
'adresse de al cellule contenant un commentaire
Cells(ligne, 2) = f.Cells(c.Row, 3)
'nom
Cells(ligne, 3) = c.Value
'contenu de la cellule
temp = c.Comment.Text
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
'contenu du commentaire
ligne = ligne + 1
End If
Next c
Application.EnableEvents = True
End Sub

Daniel

Bonjour,

Une autre façon de faire :
Tu dois adapter le nom de la feuille où sont les commentaires.

'----------------------------------------
Sub test()
Dim C As Comment, X As String, A As Long
Dim Sh As Worksheet

Set Sh = Worksheets.Add
With Sh
.Range("A1") = "Colonnes"
.Range("B1") = "Lignes"
.Range("C1") = "Commentaires"
.Range("A1:C1").Font.Bold = True
End With

Application.ScreenUpdating = False
'Feuille où sont les commentaires à adapter
A = 1
With Worksheets("Feuil1")
For Each C In .Comments
X = LCase(C.Parent.EntireColumn.Address(0, 0))
Select Case X
Case Is = "k:k", "u:u", "ae:ae", "ao:ao", "ay:ay", _
"bi:bi", "bs:bs", "cc:cc", "cm:cm", _
"cw:cw", "dg:dg", "dq:dq"
A = A + 1
With Sh
.Range("A" & A) = C.Parent.EntireColumn.Address(0, 0)
.Range("B" & A) = C.Parent.Row
.Range("C" & A) = Replace(C.Shape.OLEFormat _
.Object.Text, Chr(10), "")
End With
End Select
Next
End With
With Sh
With .Range("A1:C" & .Range("A65536").End(xlUp).Row)
.Sort Key1:=.Item(2, 1), order1:=xlAscending, _
Key2:=.Item(2, 2), order2:=xlAscending, Header:=xlNo
.EntireColumn.AutoFit
.Resize(, .Columns.Count - 1).HorizontalAlignment = xlHAlignCenter
End With

End With
Application.ScreenUpdating = True
End Sub
'----------------------------------------



MichD
--------------------------------------------
"J@@" a écrit dans le message de groupe de discussion : is4ngc$t3p$1@speranza.aioe.org...

Bonjour à tous

Grâce à un code venant de chez J Boisgontier je récupère *tous* les
commentaires d'une feuille (ainsi que d'autres données).

Mais je souhaiterais ne récupérer que les commentaires venant de
certaines colonnes, par exemple ici celles mises en array :
ArCol = Array("k:k", "u:u", "ae:ae", "ao:ao", "ay:ay", "bi:bi", "bs:bs", _
"cc:cc", "cm:cm", "cw:cw", "dg:dg", "dq:dq")

Comment adapter le code de la macro, svp?
'********************
Private Sub Worksheet_Activate()
Set f = Sheets("Feuil1")
ligne = 2
For Each C In f.Comments
adr = C.Parent.Address
Cells(ligne, 1) = adr
'adresse de al cellule contenant un commentaire
Cells(ligne, 2) = f.Cells(Range(adr).Row, 3)
'nom
Cells(ligne, 3) = f.Range(adr)
'contenu de la cellule
temp = C.Text
Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
'contenu du commentaire
ligne = ligne + 1
Next C
End Sub
'********************
Merci
@+
J@@

Bonjour MichD
Excellent, comme d'habitude.
Juste modifié le filtre "A2" pour éviter d'embarquer la ligne de titre
dans le tri :
With .Range("A2:C" & .Range("A65536").End(xlUp).Row)

Merci et bonne journée
@+
J@@

Le 01/06/2011 00:58, MichD a écrit :

'----------------------------------------
Sub test()
Dim C As Comment, X As String, A As Long
Dim Sh As Worksheet

Set Sh = Worksheets.Add
With Sh
.Range("A1") = "Colonnes"
.Range("B1") = "Lignes"
.Range("C1") = "Commentaires"
.Range("A1:C1").Font.Bold = True
End With

Application.ScreenUpdating = False
'Feuille où sont les commentaires à adapter
A = 1
With Worksheets("Feuil1")
For Each C In .Comments
X = LCase(C.Parent.EntireColumn.Address(0, 0))
Select Case X
Case Is = "k:k", "u:u", "ae:ae", "ao:ao", "ay:ay", _
"bi:bi", "bs:bs", "cc:cc", "cm:cm", _
"cw:cw", "dg:dg", "dq:dq"
A = A + 1
With Sh
.Range("A"& A) = C.Parent.EntireColumn.Address(0, 0)
.Range("B"& A) = C.Parent.Row
.Range("C"& A) = Replace(C.Shape.OLEFormat _
.Object.Text, Chr(10), "")
End With
End Select
Next
End With
With Sh
With .Range("A1:C"& .Range("A65536").End(xlUp).Row)
.Sort Key1:=.Item(2, 1), order1:=xlAscending, _
Key2:=.Item(2, 2), order2:=xlAscending, Header:=xlNo
.EntireColumn.AutoFit
.Resize(, .Columns.Count - 1).HorizontalAlignment = xlHAlignCenter
End With

End With
Application.ScreenUpdating = True
End Sub
'----------------------------------------

C'est moi qui ai induit Excel en erreur avec ceci :
Header:=xlNo
Il aurait fallu que ce paramètre soit à XlYes

;-))


MichD
--------------------------------------------