VBA: Transferer des commentaires dans des cellulles

Version imprimable

20/08/2007, 11h21
Monteninho

VBA: Transferer des commentaires dans des cellulles

Bonjour a vous devellopeur,

Je souhaiterais savoir si il existe une possibilite de transferer un commentaire de cellule sous excel dans une cellule.

Mon tableau est comme suit:

Colonne A B C D
ligne
1 xxx xxx xxx xxxx (avec un commentaire colonne D)
2 yyyy yyyy yyyy yyyyy
3 ddddd dddd dddd ddddd
4 eeeee eeee eeee eeeee

Et je souhaite inserer le commentaire cellule D1, en dessous sur autant de nouvelles lignes qu'en comporte le commentaire.

Le commentaire se presente toujours comme suit:

Utilisateur: fffff-ddd
gggg-tete
ttttt-ddsds
eeee-sssss

Colonne A B C D
ligne
1 xxx xxx xxx fffff-ddd
2 gggg-tete
3 ttttt-ddsds
4 eeee-sssss
5 yyyy yyyy yyyy yyyyy
6 ddddd dddd dddd ddddd
7 eeeee eeee eeee eeeee

Voila, j'ai un peu cherche si on pouvait le faire mais j'ai rien trouve de concret.

Merci d'avance.
20/08/2007, 11h32
ouskel'n'or
Je suppose le commentaire en B5
Code:

1 2 Blabla = range("B5").comment.text range("B6").value = blabla
Teste ça en adaptant...
20/08/2007, 11h39
Monteninho

Merci ouskel'nor,

ET il me faudrais aussi, le code If qui detectera les cellulesou appliquer ce code.

Exemple:

Si il existe un commentaire en cellule B5, alors copier le comm........

je trouve pas le code qui reconnait si une cellule a un commentaire.

desole de rajouter des questions

Merci pour ton aide

J'ai teste ton code ouskelnor,

Mais en fait, je veux recuperer que les codes dans le commentaires(pas le nom d'utilisateur)
et chaque code doit etre transferer dans une nouvelle ligne. avec l'enregistreur de Macro, j'obtiens ca:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Sub Macro1() ' ' Macro1 Macro ' Macro recorded 20/08/2007 by Y.Monte ' ' Range("E7").Select Range("E7").Comment.Text Text:="Y.Monte:" & Chr(10) & "456-56" & Chr(10) & "458-56" & Chr(10) & "4256-896" & Chr(10) & "" Range("E8").Select ActiveSheet.Paste Range("E8:E10").Cut Destination:=Range("E7:E9") Range("E7:E9").Select End Sub
Mais c'est du manuel, il recherche pas de lui même le commentaire à copier.

Merci encore

Tu arrêtes d'en ajouter une couche à chaque post ? :mouarf:
Bon. "Comment" n'a pas la propriété Range ou address, donc il faut se débrouiller autrement.
Tu parcours toutes les cellules de la colonne en vérifiant qu'il y ait quelque chose dans les commentaire.
Malheureusement, si le commentaire n'existe pas, ça plante.
Heureusement il existe "ça qu'il faut" à mettre "où il faut" pour outrepasser l'erreur.
Je suppose tes commentaires dans la colonne B, et que tu veux en placer le texte sans le nom de l'utilisateur dans la colonne A. Tu corrigeras. Je te propose donc ça :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Dim Plage as range
Dim Cell as range
Dim DerniereLigne as long
Dim Blabla as string
    'Recherche de la dernière ligne de la colonne contenant les commentaires
    DerniereLigne = Range("A65535").End(xlUp).Row
 
    'Avec la ligne suivante si une erreur survient on exécute la ligne suivante
    '... et s'il y en a une sur la suivante, on passe sur celle qui suit
    On Error Resume Next
 
    'On instancie la plage à examiner (de la ligne 1 à dernière ligne)
    Set Plage = Range("B1:B" & DerniereLigne)
 
    'On parcoure la plage ligne par ligne (Cell est l'instance de la cellule examinée
    For Each Cell In Plage
        If Cell.Comment.Text = "" Then
                'là, ça plante... Normal, on passe à la ligne suivante
            Else 'si ça plante on sort du if
 
                'Si on est là, c'est qu'il y a un commentaire
                'On extrait le texte sans le nom de l'utiisateur (généralement suivi de deux points)
                'Je te laisse regarder dans l'aide à Mid et à Instr
                Blabla = Mid(Cell.Comment.Text, InStr(Cell.Comment.Text, ":") + 1, _
                Len(Cell.Comment.Text) - InStr(Cell.Comment.Text, ":"))
 
                'Pour supprimer les sauts de lignes dans les commentaires, ajoute cette ligne
                blabla = Replace(Blabla, vblf, "")
 
                'On place dans la colonne A, sur la ligne de Cell le texte du commentaire
                Range("A" & Cell.Row).Value = Blabla
        End If
        Blabla = "" 
    Next
    'on supprime l'instance de Plage
    Set Plage = Nothing
 
    'On supprime la gestion d'erreur
    On Error GoTo 0

Avec ce code, il est possible que ça plante si tu as un commentaire avec le seul nom de l'utilisateur mais avec la gestion d'erreur, le seul effet serait de coller l'ancienne valeur de Blabla dans la cellule A & NoLigne
En ajoutant Blabla = "" après chaque ligne, en fin de boucle, ça devrait aller.
D'ailleurs je l'ajoute ;)
A+

20/08/2007, 12h30
Monteninho

Ah!!!!

Ca a l'air super simple comme ca.

G pa tout compris dans le code, je regarde ca de plus pres, je le teste et te reponds des que possible.

Et promis j'arrete de rajouter des lignes.

Merci
20/08/2007, 12h34
ouskel'n'or

Retourne sur mon post dans quelques minutes, j'ajoute les commentaires.
En attendant tu peux faire la sieste :zzz:
20/08/2007, 12h51
Monteninho

Ok, cool j'ai compris
Mais en fait, je souhaite avoir chaque ligne de comm dans une nouvelles ligne de tableau.
les comm sont fait de facon, a ceux que chaque nouvelles ref dans le comm soit sur une nouvelle ligne dans ce dernier.
et moi g besoin de les individualiser ligne par ligne.

Ton code est presaue complet pour ce que je veu faire. il reste juste a lui dire d'inserer dans une nouvelle ligne chaque ref en commencant sur la cellule contenant le comm.

en gros ca donne ca
avant:

YYYY
DDDD
EEEE

(cellulle YYYY avec comm "Utilisateur:564-58
987-56
654-852)

Resultat
564-58
987-56
654-852
DDDD
EEEE

Je suis vraiment desole de rajouter des contraintes comme ca. Mais je vois pas du tout comment separer en plusiuers lignes le commentaire
:oops:

Merci oskelnor
20/08/2007, 12h55
ouskel'n'or

Donc, pour chaque référence, tu dois ajouter une nouvelle ligne ?
20/08/2007, 13h03
Monteninho

1 pièce(s) jointe(s)

Tout a fait

tiens voila un exemple en piece jointe du type de doc et le resulte a obtenir.

EN fait, le comm contient deux ref qui seront par la suite separer dans deux ciolonnes diffrentes et un prix qui sera envoye dans une autre colonne mais ca je sais faire. enfin je crois.

Le trcu c juste de creer des nouvelles lignes avec les differentes reference. en fait ca fatigue, la personne qui m'envoie les ref de taper sur plusieurs lignes.

Merci
20/08/2007, 13h13
ouskel'n'or
Ok.
Tu dois donc commencer par connaître le nombre de références contenues dans le commentaire, ajouter autant de lignes que de références, et enfin ajouter une référence par ligne ajoutée
Si les références se trouvent sur des lignes différentes dans le commentaire, tu peux les retrouver en mettant
Code:

1 2 Blabla = Split(Mid(Cell.Comment.Text, InStr(Cell.Comment.Text, ":") + 1, _ Len(Cell.Comment.Text) - InStr(Cell.Comment.Text, ":")), vblf)
où Blabla devient un tableau des références.
Pour voir ce que donne cette ligne, ajoute à la suite ces trois lignes (à supprimer ensuite)
Code:

1 2 3 For i = 1 to Ubound(Blabla) Msgbox Blabla(i) Next
Quand tu auras vu ça, on passera à la suite
Ubound(Blabla) - 1 donne le nombre de lignes à ajouter. Où -1 correspond à la ligne courante qui n'est pas à ajouter (!)
A+

Aiie!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Dim i As Integer
Dim Plage As Range
Dim Cell As Range
Dim DerniereLigne As Long
Dim Blabla As String
    'Recherche de la dernière ligne de la colonne contenant les commentaires
    DerniereLigne = Range("A65535").End(xlUp).Row
 
    'Avec la ligne suivante si une erreur survient on exécute la ligne suivante
    '... et s'il y en a une sur la suivante, on passe sur celle qui suit
    On Error Resume Next
 
    'On instancie la plage à examiner (de la ligne 1 à dernière ligne)
    Set Plage = Range("G1:G" & DerniereLigne)
 
    'On parcoure la plage ligne par ligne (Cell est l'instance de la cellule examinée
    For Each Cell In Plage
        If Cell.Comment.Text = "" Then
                'là, ça plante... Normal, on passe à la ligne suivante
            Else 'si ça plante on sort du if
 
                'Si on est là, c'est qu'il y a un commentaire
                'On extrait le texte sans le nom de l'utiisateur (généralement suivi de deux points)
                'Je te laisse regarder dans l'aide à Mid et à Instr
            Blabla = Split(Mid(Cell.Comment.Text, InStr(Cell.Comment.Text, ":") + 1, _
                Len(Cell.Comment.Text) - InStr(Cell.Comment.Text, ":")), vbLf)
 
For i = 1 To UBound(Blabla)
    MsgBox Blabla(i)
Next

j'ai essaye ca, mais ca marche pas
MESSAGE D'ERREUR:
Compiled error:
exected array

et c l'expression Ubound qui est surligne
Dsl

Ok, on va séparer les fonctions. En outre on ne sait pas a priori si ton commentaire contient plusieurs lignes.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
    DerniereLigne = Range("A65535").End(xlUp).Row
    On Error Resume Next
    Set Plage = Range("B1:B" & DerniereLigne)
    For Each Cell In Plage
        If Cell.Comment.Text = "" Then
            Else
            blabla = Mid(Cell.Comment.Text, InStr(Cell.Comment.Text, ":") + 1, _
            Len(Cell.Comment.Text) - InStr(Cell.Comment.Text, ":"))
        End If
        blabla = Mid(Cell.Comment.Text, InStr(Cell.Comment.Text, ":") + 1, _
                Len(Cell.Comment.Text) - InStr(Cell.Comment.Text, ":"))
        If InStr(blabla, vbLf) <> 0 Then
            Tableau = Split(blabla, vbLf)
            For i = 1 To UBound(Tableau)
                MsgBox Tableau(i)
                'Range("A" & Cell.Row).Value = Tableau(i) 'à voir plus tard
            Next
        End If
        blabla = ""
        Tableau = ""
    Next
    Set Plage = Nothing
    On Error GoTo 0

Teste ça, de mon côté c'est ok

Edit
J'ai corrigé la ligne, le tableau commence à 0

Code:

For i = 0 To UBound(Tableau)

20/08/2007, 14h13
Monteninho

Ok c good, pour la message box, j'ai bien les ref une a une

Tu peu expliquer la suite, merci

Tu as constaté que Ubound donne un nombre inférieur de 1 du nombre de références.
Pour chaque ligne examinée (le N° de ligne est donné par Cell.row) on va donc ajouter Ubound(Tableau) lignes, puis recopier sur ces lignes le contenu de la ligne Cell.row.
Ensuite que tu colleras, dans la bonne colonne, la valeur de Tableau(i) sur chacune de ces lignes dupliquées.
Comme i est l'indice du tableau, tu devras l'ajouter à cell.row

Une remarque : Tu peux avoir un retour à la ligne sans référence (erreur de frappe par ex)... auquel cas le dernier indice du tableau sera vide
On vérifie que ce ne soit pas le cas pour avoir le nombre de références
Code:

1 2 3 4 5 6 7 8 9 10 NoCol = 1 'N° de colonne où tu places tes références - Tu adaptes NbRef = Ubound(Tableau) 'Vérification : Si le dernier indice du tableau est vide, on l'élimine If trim(Tableau(NbRef)) = "" then NbRef = NbRef - 1 'Insertion de NbRef lignes en dessous de la ligne lue 'La copie de la ligne courante et son collage sur les NbRef suivantes 'Ensuite on peut renseigner chaque ligne For i = 0 to NbRef Range(Cell.row + i, NoCol).Value = Tableau(i) Next
Pour lire la ligne suivante, tu devras ajouter le nombre de ligne vrai.
Or la boucle "For each Cell in plage" ne le permet pas.
Tu vas devoir faire une boucle
Code:

1 2 3 4 5 6 7 8 NoLigne = 1 NoColCommentaire = 2 'à adapter Do While Cells(NoLigne, NoColCommentaire).value <> "" 'Le test sur l'existence d'un commentaire 'Insertion + Copie + Collage 'Le traitement s'il existe (le code que je viens de mettre plus haut NoLigne = NoLigne + 1 Loop
Je te donne le principe, pour le code, donne-nous quelque chose, on pourra toujours corriger. Là, j'ai du w qui m'attend ;)
A+

1 pièce(s) jointe(s)

Bien, voila le coden complet Ouskel nor,

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Sub comm()
 
NoLigne = 1
NoColCommentaire = 7 'à adapter
Do While Cells(NoLigne, NoColCommentaire).Value <> ""
 
DerniereLigne = Range("A65535").End(xlUp).Row
    On Error Resume Next
    Set Plage = Range("G1:G" & DerniereLigne)
    For Each Cell In Plage
        If Cell.Comment.Text = "" Then
            Else
            Blabla = Mid(Cell.Comment.Text, InStr(Cell.Comment.Text, ":") + 1, _
            Len(Cell.Comment.Text) - InStr(Cell.Comment.Text, ":"))
        End If
        Blabla = Mid(Cell.Comment.Text, InStr(Cell.Comment.Text, ":") + 1, _
                Len(Cell.Comment.Text) - InStr(Cell.Comment.Text, ":"))
        If InStr(Blabla, vbLf) <> 0 Then
            Tableau = Split(Blabla, vbLf)
           ' For i = 0 To UBound(Tableau)
            '    MsgBox Tableau(i)
                'Range("A" & Cell.Row).Value = Tableau(i) 'à voir plus tard
           ' Next
        End If
       ' Blabla = ""
        'Tableau = ""
    Next
    Set Plage = Nothing
    On Error GoTo 0
        NoCol = 7 'N° de colonne où tu places tes références - Tu adaptes
NbRef = UBound(Tableau)
'Vérification : Si le dernier indice du tableau est vide, on l'élimine
If Trim(Tableau(NbRef)) = "" Then NbRef = NbRef - 1
'Insertion de NbRef lignes en dessous de la ligne lue
'La copie de la ligne courante et son collage sur les NbRef suivantes
'Ensuite on peut renseigner chaque ligne
For i = 0 To NbRef
     Range(Cell.Row + i, NoCol).Value = Tableau(i)
 
Next
     'Le test sur l'existence d'un commentaire
     'Insertion + Copie + Collage
     'Le traitement s'il existe (le code que je viens de mettre plus haut
     NoLigne = NoLigne + 1
Loop
    End Sub

Erreur:

Run time error:13
type mismatch

Quanfd tu aura le temps, essaie de me dire ce qui deconne,

le debogueur surligne Nbref= Ubond(tableau)

je te renvoie le tableau avec le code.

20/08/2007, 15h18
ouskel'n'or

Relis-moi (le dernier post). For each cell in ..... ne peut pas fonctionner si tu ajoutes des lignes.
Dès que j'ai un moment, je regarde.
20/08/2007, 17h35
ouskel'n'or

Citation:

Envoyé par Monteninho

Bien, voila le coden complet Ouskel nor,
Erreur:
Run time error:13
type mismatch
le debogueur surligne Nbref= Ubond(tableau)
je te renvoie le tableau avec le code.

Normal que ça ne fonctionne pas, tu dois repenser ton code en entier en remplaçant la boucle For each Cell in Plage... par une boucle Do While puisque le nombre de lignes varie en cours de boucle.
Ensuite, tu dois modifier ta sortie de gestion d'erreur (On error goto 0) de façon à prendre en compte un tableau vide. Or rien ne dit que tous tes commentaires soient renseignés. en outre, dans le code précédent, je remettais le tableau à zéro pour remplir le tableau suivant. Donc en sortie de boucle il est vide. Etc.
Essaie de te mettre en français le déroulement de ta procédure puis de l'écrire en utilisant les différentes parties que je t'ai passées (hormis la boucle for each... bien entendu, puisque tu l'auras remplacée par une boucle Do While.)

Juste un mot : Tu vois ici ce qu'il en coûte de poser un problème sans l'avoir cerné entièrement. J'ai commencé à te répondre, puis j'ai dû modifier une première fois ma réponse et maintenant il est nécessaire de tout repenser avec tes nouvelles demandes.
Penses-y la prochaine fois ;)

Présente-nous un code qui intègre l'ensemble, on verra ce qu'on peut en faire s'il ne fonctionne pas. Mais tu peux jeter ton code précédent :cry:
Je vais tâcher d'ajouter la partie concernant la copie de ligne mais je ne te promets rien.
A+

Bon, j'avais deux minutes

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Sub Test()
Dim NoLigne, DerniereLigne, NoCol, NoColCommentaire, DerniereColonne
Dim i, NbRef, blabla, Tableau
    DerniereLigne = Range("A65535").End(xlUp).Row
    On Error Resume Next
    NoLigne = 1
    NoCol = 1 'N° de colonne où tu places tes références - Tu adaptes
    NoColCommentaire = 2 '... à adapter
    Do While Cells(NoLigne, NoColCommentaire).Value <> ""
        NbRef = 0
        blabla = ""
        Tableau = ""
        If Cells(NoLigne, NoColCommentaire).Comment.Text = "" Then
                'Le commentaire n'existe pas => Erreur
            Else
                blabla = Mid(Cells(NoLigne, NoColCommentaire).Comment.Text, _
                InStr(Cells(NoLigne, NoColCommentaire).Comment.Text, ":") + 1, _
                Len(Cells(NoLigne, NoColCommentaire).Comment.Text) - _
                InStr(Cells(NoLigne, NoColCommentaire).Comment.Text, ":"))
        End If
        If InStr(blabla, vbLf) <> 0 Then
            Tableau = Split(blabla, vbLf)
            NbRef = UBound(Tableau) 'Nombre de ligne à ajouter = Nbre références - 1
        End If
        'Insertion de NbRef lignes en dessous de la ligne lue
        If NbRef > 0 Then
        'Vérification : Si le dernier indice du tableau est vide, on l'élimine
            If Trim(Tableau(NbRef)) = "" Then NbRef = NbRef - 1 'NbRef = Nbre lignes à ajouter
            For i = 1 To NbRef
                Cells(NoLigne + 1, 1).EntireRow.Insert Shift:=xlDown
            Next
 
            'Copie de la ligne courante et collage sur les NbRef lignes suivantes
            DerniereColonne = Range("IV1").End(xlToLeft).Column
            Range(Cells(NoLigne, 1), Cells(NoLigne, DerniereColonne)).Copy _
               Destination:=Range(Cells(NoLigne + 1, 1), Cells(NoLigne + NbRef, DerniereColonne))
 
            'Ensuite on peut renseigner chaque nouvelle ligne de la référence
            'Comme i = 0 au départ, on commence par la ligne contenant le commentaire
            For i = 0 To NbRef
                 Cells(NoLigne + i, NoCol).Value = Tableau(i)
            Next
        End If
        'On incrémente le NoLigne de 1 + NbRef correspondant au nbre de lignes ajoutées
        NoLigne = NoLigne + 1 + NbRef
    Loop
    On Error GoTo 0
 
    Exit Sub 'A supprimer quand tu auras vérifié que le code fait bien ce que tu veux...
    '... ce qui activera les lignes suivantes et supprimera tous les commentaires
 
    For Each Commentaire In Worksheets("Feuil4").Comments
        Commentaire.Delete
    Next
End Sub

Si tu n'as pas compris quelque chose, demande-le pour ne pas te coucher avec ça sur la conscience :mouarf:

21/08/2007, 09h31
Monteninho

Salut Ouskel nor,

desole je n'ai pas pu voir ca hier. J'ai teste le code.
ca marche. Je comprend plutot bien le code. reste a decouvrir certaines syntaxes.

Pb resolu

Merci pour tout,