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

Le
J
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@@
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
DanielCo
Le #23406781
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@@
J
Le #23406901
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@@




DanielCo
Le #23406981
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@@
J
Le #23406971
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@@




J
Le #23407001
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@@




DanielCo
Le #23407051
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@@
J
Le #23407041
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

MichD
Le #23407561
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$

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@@
J
Le #23410641
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
'----------------------------------------

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

;-))


MichD
--------------------------------------------
Publicité
Poster une réponse
Anonyme