VBA: Transferer des commentaires dans des cellulles

**Monteninho** · 20/08/2007, 11h21

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.

**ouskel'n'or** · 20/08/2007, 11h32

Je suppose le commentaire en B5

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
    Blabla = range("B5").comment.text
    range("B6").value = blabla

Teste ça en adaptant...

**Monteninho** · 20/08/2007, 11h39

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

**Monteninho** · 20/08/2007, 11h45

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**ouskel'n'or** · 20/08/2007, 12h25

Tu arrêtes d'en ajouter une couche à chaque post ?

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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+

**Monteninho** · 20/08/2007, 12h30

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

**ouskel'n'or** · 20/08/2007, 12h34

Retourne sur mon post dans quelques minutes, j'ajoute les commentaires.
En attendant tu peux faire la sieste

**Monteninho** · 20/08/2007, 12h51

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

Merci oskelnor

**ouskel'n'or** · 20/08/2007, 12h55

Donc, pour chaque référence, tu dois ajouter une nouvelle ligne ?

**Monteninho** · 20/08/2007, 13h03

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

**ouskel'n'or** · 20/08/2007, 13h13

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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+

**Monteninho** · 20/08/2007, 13h26

Aiie!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**ouskel'n'or** · 20/08/2007, 13h56

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

    For i = 0 To UBound(Tableau)

**Monteninho** · 20/08/2007, 14h13

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

Tu peu expliquer la suite, merci

**ouskel'n'or** · 20/08/2007, 14h41

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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+

**Monteninho** · 20/08/2007, 14h56

Bien, voila le coden complet Ouskel nor,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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.

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

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.

**ouskel'n'or** · 20/08/2007, 17h35

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

Je vais tâcher d'ajouter la partie concernant la copie de ligne mais je ne te promets rien.
A+

**ouskel'n'or** · 20/08/2007, 18h37

Bon, j'avais deux minutes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Monteninho** · 21/08/2007, 09h31

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,

VBA: Transferer des commentaires dans des cellulles

Macros et VBA Excel

Discussions similaires

Partager

Partager