[XL-2010] Macro comparaison et transposition

Macro comparaison et transposition

bonjour,

étant débutante en VBA, je bloque depuis 2 jours sur la manip que je dois faire.
En fait, j'ai un fichier excel à 2 feuilles, sur la premier j'ai un fichier de type :
cadre (colA)        nom(colB)
1                          a
1                          b
1                          c
2                          a
3                          a
3                          b             
sur ma feuille 2 j'ai un fichier de type
cadre (colA) nom1(colB) nom2(colC) nom3(colD) nomX(colX)
1 a b c
2 a
3 a b

J'ai bien réussi à importer mes noms de cadre en supprimant les doublons de façons à n'avoir que des valeurs uniques, en revanche je ne sais pas comment coder la boucle qui permettrait pour un numéro de cadre donné dans la feuille 2 de copier et de coller les pacages correspondants mais en ligne cette fois
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Sub import_visite() 'import_visite Macro' Sheets("lyon").Select Columns("A:A").Select Selection.Copy Sheets("siege").Select Columns("A:A").Select ActiveSheet.Paste Application.CutCopyMode = False ActiveSheet.Range("$A$1:$AH$2397").RemoveDuplicates Columns:=1, Header:= _ xlYes End Sub
Voilà j'espère avoir été assez claire :) Quelqu'un pour m'aider ?

bonne journée à tous !

Bonjour,

Pour chaque cadre, est-ce qu'il peut y avoir des noms qui se répètent ?

non par cadre un seul nom possible :)

Ceci devrait faire l'affaire.
À adapter selon ton fichier.
Je présume des entêtes en ligne 1 et les données sur les lignes suivantes

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
Sub CopieTranspose()
    Dim I As Long, nbLignes As Long
    Dim Tablo
    Dim Recherche As Range
 
    'Copie des cadres sans doublons
    Sheets("lyon").Columns("A:A").Copy Sheets("siege").Range("A1")
    Application.CutCopyMode = False
    Sheets("siege").Columns("A").RemoveDuplicates Columns:=1, Header:=xlYes
 
    'Création d'un tableau avec les cadres uniques
    nbLignes = Sheets("siege").Cells(Rows.Count, "A").End(xlUp).Row
    Tablo = Sheets("siege").Range("A2:A" & nbLignes).Value
 
    Sheets("lyon").AutoFilterMode = False
    Sheets("lyon").Rows(1).AutoFilter
 
    'Copie transposée des noms
    nbLignes = Sheets("lyon").Cells(Rows.Count, "A").End(xlUp).Row
    For I = 1 To UBound(Tablo)
        Sheets("lyon").Rows(1).AutoFilter Field:=1, Criteria1:=Tablo(I, 1)
        Sheets("lyon").Range("B2:B" & nbLignes).SpecialCells(xlCellTypeVisible).Copy
        Set Recherche = Sheets("siege").Columns("A").Find(Tablo(I, 1), LookIn:=xlValues, LookAt:=xlWhole)
        If Not Recherche Is Nothing Then
            Sheets("siege").Range("B" & Recherche.Row).PasteSpecial xlPasteValues, Transpose:=True
        End If
    Next
End Sub

ça marche nickel,

Merci beaucoup !!