Macro VBA pour copier des données

Version imprimable

24/01/2020, 13h30
Juliens06

1 pièce(s) jointe(s)

Macro VBA pour copier des données

Bonjour à tous,

Je me permets de solliciter votre aide car je n’arrive pas à réaliser une macro permettant de répondre à mon besoin.
Je vous joins un classeur exemple.
Concrètement, chaque personne dispose de fonctions dont le nombre peut varier (dans l’exemple, 3 fonctions actuelles).
Sous chaque fonction est indiqué le nom (en colonne A), en colonne E est indiqué l’identifiant et en colonne H, la date d’effet.

Ce que je souhaiterai est crééer une macro qui arrangerait le fichier pour avoir, sur la même ligne :
- La fonction
- Le nom
- L’identifiant correspondant
- La date d’effet

Je ne sais pas comment m’y prendre sachant que ces informations ne sont pas sur le même ligne à l’origine, que le nombre de fonction peut varier et que ces informations ne sont pas toujours placées sur une ligne en particulier (dans mon exemple par exemple, la fonction 1 se retrouve en ligne 23, mais dans un autre exemple, elle peut se retrouver en ligne 25).

Pourriez-vous m’aider s’il vous plait ?

Merci par avance.
24/01/2020, 14h15
halaster08

Bonjour,

Une proposition sans vba, si besoin l'enregistreur de macro te donnera le code correspondant
1) Tri tes données par identifiant
2)Dans une nouvelle colonne sur la premiere ligne de données mettre la formule: =A2&";"&H2 Puis sur les lignes en dessous la formule =SI(E3=E2;I2&";"&A3&":"&H3;A3&":"&H3) Copie en valeur les résultat obtenu
Tu obtiens dans une cellule la liste des nom et date séparée par un point-virgule
3) Ajoute une colonne qui compte le nombre de caractère puis tri décroissant sur cette valeur et suppression de doublon par identifiant
Il te reste une ligne par identifiant avec toutes les infos dans une cellule
4) Utilise la fonction donnée->convertir->séparateur ;
Et voilà tu a maintenant une colonne par nom et date
24/01/2020, 14h26
Menhir

Personnellement, j'utiliserais simplement une fonction DECALER() avec comme décalage verticale une formule du style LIGNE()*5+COLONNE() (à ajuster en ajoutant/soustrayant une valeur fixe en fonction de la position de destination des valeurs et de la cellule de référence du DECALER).

En tout cas, c'est ce que je fais chaque fois que j'ai à réorganiser des données de ce type.

Copier des données

Bonjour,

Le fichier que tu donnes est difficile à traiter parce qu'il y a beaucoup de cellules fusionnées.
Commence par enlever les cellules fusionnées et adapte ce code que j'ai testé qui remonte le nom et la référence pour les 3 fonctions.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Sub Test2() Dim plage As Range Dim i As Byte Dim ma_table() Set plage = Worksheets(1).UsedRange ma_table = Array("Fonction 1", "Fonction 2", "Fonction 3") For i = 0 To 2 With plage Worksheets(2).Cells(i + 1, 1) = .Find(What:=ma_table(i)).Offset(rowOffset:=1) 'nom Worksheets(2).Cells(i + 1, 2) = .Find(What:=ma_table(i)).Offset(rowOffset:=2, columnOffset:=1) 'référence End With Next i End Sub
La réorganisation par ligne se fait dans la deuxième feuille : Worksheets(2).
Le tableau donnée est supposé être dans la première feuille : Worksheets(1).

24/01/2020, 16h52
Juliens06

1 pièce(s) jointe(s)

Bonjour,

Tout d'abord merci de vos réponses !
Je pense que je n'ai pas été très clair dans ma demande et je m'en excuse.
J'ai modifié mon classeur et j'ai mis sur le coté ce que je souhaiterai obtenir. Rn gros avoir un tableau avec sur une seule ligne l'ensemble des informations.

Merci beaucoup

VBA copier des données

Maintenant que tu as enlevé les cellules fusionnées et que tu as mis le résultat final, c'est très simple.

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
 
Sub Test2()
 
    Dim plage As Range
    Dim i As Byte
    Dim ma_table()
 
    Set plage = Worksheets(1).Range("A1:H50")
    ma_table = Array("Fonction 1", "Fonction 2", "Fonction 3")
 
    For i = 0 To 2
 
        With plage
 
            Cells(i + 23, 15) = ma_table(i)
            Cells(i + 23, 16) = .Find(What:=ma_table(i)).Offset(rowOffset:=1) 'nom
            Cells(i + 23, 17) = .Find(What:=ma_table(i)).Offset(rowOffset:=2, columnOffset:=4) 'identifiant
            Cells(i + 23, 18) = .Find(What:=ma_table(i)).Offset(rowOffset:=2, columnOffset:=6) 'référence
            Cells(i + 23, 19) = .Find(What:=ma_table(i)).Offset(columnOffset:=7) 'date
 
        End With
 
    Next i
 
End Sub

Bon courage.

29/01/2020, 09h10
Juliens06

Super ! Merci beaucoup !
En revanche, si dans le fichier j'ai plus que 3 fonctions comment puis-je m'y prendre ? Sachant que le "fonction 1", "Fonction 2" … ont été modifiés pour l'exemple, mais en vrai, leurs noms peuvent être différents.

Merci beaucoup.
29/01/2020, 10h32
Menhir

Remplace le For To par :

Code:

For i = LBound(ma_table) To UBound(ma_table)

Et remplie le Array avec l'ensemble de tes fonctions.
29/01/2020, 17h39
Juliens06

Top merci ! un problème de résolu.
J'ai encore une dernière question car le souci se présente.
Il peut arriver que les noms des fonctions soient équivalentes, c'est à dire que nous ayons "Fonction 1" plusieurs fois à la suite, mais les informations en dessous changent. Il est donc nécessaire que dans le tableau créé avec la macro, toutes "Fonction 1" ressortent à la suite.
Avec la macro fourni, il est toujours repris uniquement les données du premier champs renseigné "Fonction 1".
Y'at-t-il une solution à cela ?

Désolé si je ne suis pas très claire.

VBA copier des données

Voilà le code pour entrer Fonction 1 ou Fonction 9999. Il suffit de mettre une * après fonction et tester qu'on ne retourne pas sur la première occurence pour éviter une boucle sans fin.

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
 
Sub test3()
 
    Dim plage As Range
    Dim occur As Range
    Dim mot As String
    Dim premier_match As String
    Dim i As Integer
 
    mot = "Fonction *"
    Set plage = Worksheets(1).Range("A1:H50")
    Set occur = plage.Find(What:=mot)
 
    With plage
 
        If Not occur Is Nothing Then
            premier_match = occur.Address
            Do
                i = i + 1
                Cells(i + 22, 15) = occur.Value 'fonction
                Cells(i + 22, 16) = occur.Offset(rowOffset:=1) 'nom
                Cells(i + 22, 17) = occur.Offset(rowOffset:=2, columnOffset:=4) 'identifiant
                Cells(i + 22, 18) = occur.Offset(rowOffset:=2, columnOffset:=6) 'référence
                Cells(i + 22, 19) = occur.Offset(columnOffset:=7) 'date
                Set occur = plage.FindNext(occur)
            Loop While Not occur Is Nothing And occur.Address <> premier_match
        End If
 
    End With
 
End Sub

30/01/2020, 08h34
Menhir

Citation:

Envoyé par Juliens06

Il peut arriver que les noms des fonctions soient équivalentes, c'est à dire que nous ayons "Fonction 1" plusieurs fois à la suite, mais les informations en dessous changent. Il est donc nécessaire que dans le tableau créé avec la macro, toutes "Fonction 1" ressortent à la suite.
Avec la macro fourni, il est toujours repris uniquement les données du premier champs renseigné "Fonction 1".
Y'at-t-il une solution à cela ?

Oui, ça s'appelle un tableau croisé dynamique et il n'y a pas besoin de passer par du VBA pour le mettre en place.

Macro VBA pour copier des données

Voila la version simplifiée, le "With plage" est inutile ici, à la différence du premier script avec Fonction1, Fonction2 et Fonction 3 :

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
 
Sub test4()
 
    Dim plage As Range
    Dim occur As Range
    Dim mot As String
    Dim premier_match As String
    Dim i As Integer
 
    mot = "Fonction *"
    Set plage = Worksheets(1).Range("A1:H50")
    Set occur = plage.Find(What:=mot)
 
    If Not occur Is Nothing Then
        premier_match = occur.Address
        Do
            i = i + 1
            Cells(i + 22, 15) = occur.Value 'fonction
            Cells(i + 22, 16) = occur.Offset(rowOffset:=1) 'nom
            Cells(i + 22, 17) = occur.Offset(rowOffset:=2, columnOffset:=4) 'identifiant
            Cells(i + 22, 18) = occur.Offset(rowOffset:=2, columnOffset:=6) 'référence
            Cells(i + 22, 19) = occur.Offset(columnOffset:=7) 'date
            Set occur = plage.FindNext(occur)
        Loop While Not occur Is Nothing And occur.Address <> premier_match
    End If
 
End Sub

30/01/2020, 11h27
Juliens06

Un grand grand merci ! ça fonctionne à la perfection !