Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2013 Tableau excel

rima21

XLDnaute Junior
Bonjour la communauté,
mon problème est un bête, je veux convertir ce tableau à cette forme,avez vous des solutions?

 

Pièces jointes

  • test2503.xlsx
    11.4 KB · Affichages: 16
Solution
Bonsoir ZINEB91, sylvanu, chris,

Oui pour aller vite il faut PowerQuery ou une macro VBA, voyez le fichier joint avec celle-ci :
VB:
Sub Ventiler()
Dim d As Object, tablo, resu(), n&, i&, x$, lig&, dest As Range
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With Sheets("Feuil1") 'à adapter
    tablo = .[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
    ReDim resu(1 To UBound(tablo), 1 To 2)
    resu(1, 1) = "Code": resu(1, 2) = "Contact 1" 'titres
    n = 1
    For i = 2 To UBound(tablo)
        x = tablo(i, 1)
        If d.exists(x) Then
            lig = d(x)
            resu(lig, 2) = resu(lig, 2) & Chr(1) & tablo(i, 2) 'concaténation
        Else
            n = n + 1...

chris

XLDnaute Barbatruc
Bonjour à tous

Une solution POwerQuery (intégré à Excel 2016 et +, en add on sur 2010 et 2013)

Actualiser par Données, Actualiser Tout
 

Pièces jointes

  • Croiser_PQ.xlsx
    20.9 KB · Affichages: 4

sylvanu

XLDnaute Barbatruc
Supporter XLD
Désolé, avec autant de données les formules matricielles sont extrêmement lourdes.
Pour seulement 1300 lignes ça met plus de trois minutes.
Deux solutions pragmatiques :
1- Peut on passer par du VBA ?
2- Passer par POwerQuery comme préconisé par Chris.

En PJ le fichier avec seulement 1300 lignes de recherche. Bon courage pour l'ouvrir.
 

Pièces jointes

  • KCzqF5wq1Ai_ZINEB (1).xlsx
    668.1 KB · Affichages: 3

job75

XLDnaute Barbatruc
Bonsoir ZINEB91, sylvanu, chris,

Oui pour aller vite il faut PowerQuery ou une macro VBA, voyez le fichier joint avec celle-ci :
VB:
Sub Ventiler()
Dim d As Object, tablo, resu(), n&, i&, x$, lig&, dest As Range
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With Sheets("Feuil1") 'à adapter
    tablo = .[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
    ReDim resu(1 To UBound(tablo), 1 To 2)
    resu(1, 1) = "Code": resu(1, 2) = "Contact 1" 'titres
    n = 1
    For i = 2 To UBound(tablo)
        x = tablo(i, 1)
        If d.exists(x) Then
            lig = d(x)
            resu(lig, 2) = resu(lig, 2) & Chr(1) & tablo(i, 2) 'concaténation
        Else
            n = n + 1
            d(x) = n 'mémorise le n° de ligne
            resu(n, 1) = x
            resu(n, 2) = tablo(i, 2)
        End If
    Next
    '---restitution---
    Application.ScreenUpdating = False
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set dest = .[D1] '1ère cellule de destination, à adapter
    dest.EntireColumn.Resize(, .Columns.Count - dest.Column + 1).ClearContents 'RAZ
    dest(1, 3).Resize(, .Columns.Count - dest.Column - 1).Delete xlToLeft 'supprime les titres
    dest.Resize(n, 2) = resu
    dest(1, 2).Resize(n).TextToColumns dest(1, 2), xlDelimited, Other:=True, OtherChar:=Chr(1) 'commande Convertir
    i = dest.CurrentRegion.Columns.Count
    If i > 2 Then dest(1, 2).AutoFill dest(1, 2).Resize(, i - 1)
    With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub
Il n'était pas nécessaire d'utiliser cjoint, le fichier n'est pas très gros.

A+

A+
 

Pièces jointes

  • Ventiler(1).xlsm
    370 KB · Affichages: 8

chris

XLDnaute Barbatruc
Re à tous

Il y a boire et à manger dans la colonne contact...

J'ai modifié la requête pour traiter en texte.

Edit : et adapté pour plus de 3 contacts
 

Pièces jointes

  • Croiser2_PQ.xlsx
    648 KB · Affichages: 2
Dernière édition:

chris

XLDnaute Barbatruc
RE job75

Il y a par exemple
0668284124²
0655591080COMMERCIA
0522579568/FAX0522571062
MrSOUFIANE

Tu as raison : j'avais testé 2 requêtes et pas opté pour la meilleure : il y a jusqu'à 8 contacts par Code...

Je remets le bon fichier dans le fil précédent
 
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…