[vba-e] insertions de plusieurs cellules dans une

Version imprimable

Bonjour,

Je cherche a faire une macro qui pour un numero de dossier données recopierais des informations dans une meme ligne:
Je m'explique:

J'ai une colonne ou j'ai plusieurs numero de dossier:

et une seconde ou j'ai des informations:

A B
1 il fait beau
1 le soleil brille
1 la temperature est de 19°C
1 je suis venu en vélo
2 J'ai un enfant
2 c'est une fille
3 J'ai une voiture
7 Mon ordinateur ne fonctionne pas
7 il n'est pas branché...
8 C'est mon anniversaire
8 je suis née le 22

Alors l'objectif serait, dans une autre feuille que je crée, de rassembler une meme cellule les données pour un numero de dossier
cad:

A B
1 il fait beau le soleil brille la temperature est de 19°C je suis venu en vélo
2 J'ai un enfant c'est une fille
3 J'ai une voiture
7 Mon ordinateur ne fonctionne pas il n'est pas branché
8 C'est mon anniversaire je suis née le 22

Pour l'instant voila ou j'en suis et ça ne donne pas grand chose::(
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Sub addi() Dim i As Integer Worksheets.Add Worksheets(2).Activate derligne = Worksheets(2).Cells(65535, 1).End(xlUp).Row For i = 2 To derligne If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then i = i + 1 Worksheets(1).Cells(i, 1).Copy Destination:=Worksheets(1).Cells(i, 1) End If Next End Sub
Quelqu'un aurait une idée ???
Merci .

tiens un peu de code à étudier :

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
 
Sub CreerNouvelleFeuille()
Dim fs As Worksheet 'Feuille source
Dim fd As Worksheet 'Feuille destination
Dim ilS As Integer 'Ligne dans fichier source
Dim ilD As Integer 'Ligne dans fichier destination
Dim iMemo As Integer 'Memo num dossier
Dim derligne As Integer
 
Set fs = ThisWorkbook.Sheets("Feuil1")
 
'Création feuille destination
Set fd = ThisWorkbook.Worksheets.Add
 
derligne = fs.Cells(65535, 1).End(xlUp).Row
iMemo = 0
ilD = 1
   For ilS = 2 To derligne
    If iMemo <> fs.Cells(ilS, 1) Then  'Changement de ligne
      ilD = ilD + 1
      iMemo = fs.Cells(ilS, 1)
      fd.Cells(ilD, 1) = iMemo
      fd.Cells(ilD, 2) = fs.Cells(ilS, 2)
    Else 'Case des autres lignes
    fd.Cells(ilD, 2) = fd.Cells(ilD, 2) & " " & fs.Cells(ilS, 2)
    End If
   Next
 
End Sub

J'ai modifier de façon a ce que ça fonctionne pour moi toutefois c'est ok que lorsque le "numero" est plusieurs fois dans la colonne A si par exemple le num de dossier n'apparait qu'une fois la colonne B ne veut pas me le copier...
:(

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
 
Sub CreerNouvelleFeuille()
Dim fs As Worksheet 'Feuille source
Dim fd As Worksheet 'Feuille destination
Dim ilS As Integer 'Ligne dans fichier source
Dim ilD As Integer 'Ligne dans fichier destination
Dim iMemo As String 'Memo num dossier
Dim Mem As String
 
Dim derligne As Integer
 
Set fs = ThisWorkbook.Sheets(1)
 
'Création feuille destination
Set fd = ThisWorkbook.Worksheets.Add
fs.Activate
Rows(1).Copy Destination:=Worksheets(1).Cells(1, 1)
 
 
derligne = fs.Cells(65535, 1).End(xlUp).Row
ilD = 2
   For ilS = 2 To derligne
iMemo = fs.Cells(ilS, 1)
Cells(ilS, 1).Copy Destination:=Worksheets(1).Cells(ilD, 1)
 
  If iMemo <> fs.Cells(ilS + 1, 1) Then 'Changement de ligne
fs.Cells(ilS, 1).Copy Destination:=fd.Cells(ilD, 1)
ilD = ilD + 1
 
    Else 'Case des autres lignes
 
    fd.Cells(ilD, 2) = fd.Cells(ilD, 2) & " " & fs.Cells(ilS, 2)
    End If
   Next
 
 
End Sub

12/04/2007, 17h14
SfJ5Rpw8

ben tu as peu-être un peu trop modifié...! .. pourquoi ces lignes ..Copy ..? pourquoi des "activates" inutiles.. l'utilisation des fs... et fd... te permet d'être sur d'agir sur la bonne feuille...! pourquoi avoir changer la position de iMemo = fs.Cells(ilS, 1) ... il sert plus à rien la ..!