XL 2016 Consolider les données

[anna2054]

Bonjour,

Je voudrais consolider les données (Sheet1) pour obtenir le résultat (Sheet2). Voir le fichier joint.
Comment le faire, SVP ?

Merci beaucoup.
Anna

 

[anna2054]

Merci beaucoup, Chris

 

[job75]

Je viens de modifier la macro de mon post #23 car la formule avec SUM(1/COUNTIF(P,P)) ne fonctionne pas toujours correctement, avec MATCH aucun problème.

Pour ce qui est de votre dernière demande, l'idée de supprimer les doublons de chaque colonne est pour le moins discutable...

Mais voyez le fichier joint et cette macro qui remplace chaque doublon par un espace :

Private Sub Worksheet_Activate()
Dim d1 As Object, d2 As Object, P As Range, ncol%, tablo, ub&, j%, i&, x$, resu(), lig&, xlig&, n%, decal%
Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = vbTextCompare 'la casse est ignorée
Set d2 = CreateObject("Scripting.Dictionary")
d2.CompareMode = vbTextCompare
Set P = Sheets("Sheet1").[A1].CurrentRegion
ncol = P.Columns.Count
If ncol = 1 Then ncol = 2 ': Set P = P.Resize(, 2)
P.Columns(ncol).Name = "P" 'plage nommée
ThisWorkbook.Names.Add "N", ncol 'nom défini
P.Columns(ncol).Replace "", "<vide>" 'renseigne les cellules vides
ReDim resu(1 To [MAX(1,2*SUM(N(MATCH(P,P,0)=ROW(P)))-2)], 1 To [1+(N-1)*MAX(COUNTIF(P,P))])
tablo = P.Resize(, ncol) 'matrice, plus rapide, au moins 2 éléments
P.Columns(ncol).Replace "<vide>", "" 'rétablit les cellules vides
'---remplacement de chaque doublon par un espace dans chaque colonne sauf la dernière (facultatif car l'idée est discutable)---
ub = UBound(tablo)
For j = 1 To ncol - 1
    For i = 2 To ub
        x = tablo(i, ncol) & tablo(i, j)
        If d1.exists(x) Then tablo(i, j) = " " Else d1(x) = ""
    Next i
    d1.RemoveAll 'RAZ
Next j
'---remplissage du tableau resu---
resu(1, 1) = tablo(1, ncol)
lig = 1
For i = 2 To ub
    x = tablo(i, ncol)
    If Not d1.exists(x) Then
        d1(x) = lig 'mémorise la ligne
        resu(lig + 1, 1) = x
        lig = lig + 2
    End If
    xlig = d1(x) 'récupère la ligne
    d2(x) = d2(x) + 1 'comptage
    n = d2(x)
    decal = (ncol - 1) * (n - 1)
    For j = 1 To ncol - 1
        resu(xlig, 1 + j + decal) = tablo(1, j) & n
        resu(xlig + 1, 1 + j + decal) = tablo(i, j)
Next j, i
'---restitution + MFC---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
With [A3] '1ère cellule de restitution, à adapter
    .Formula = "=MOD(ROW()-ROW(" & .Address & "),2)=0"
    x = .FormulaLocal 'pour fonctionner sur toute version
    With .Resize(UBound(resu), UBound(resu, 2))
        .Value = resu
        .FormatConditions.Add xlExpression, Formula1:=x 'MFC
        .FormatConditions(1).Font.Bold = True 'police en gras
    End With
End With
With UsedRange
    .Columns(1).AutoFit 'ajuste la largeur
    For i = 13 To .Columns.Count Step ncol - 1: .Columns(i).AutoFit: Next 'largeurs pour les adresses
End With
End Sub

Notez la cerise sur le gâteau : le traitement des cellules vides (place_id) en dernière colonne.

 

[anna2054]

Bonsoir job75,
Merci beaucoup de votre aide très précieuse.
Anna

 

[anna2054]

Re-bonsoir job75,

Je me demande si vous avez reçu mon message vous étant envoyé aujourd'hui à 13:56 ?

Ci-après sa copie :

Re-bonjour job75

Permettez-moi de vous renvoyer le fichier initial, avec quelques modification sur le Sheet2 (voir le fichier joint).

Pourriez-vous bien vouloir modifier le macro pour que les champs "name" et "address" ne se répètent pas et apparaissent en une seule fois pour chacune des valeurs de "place_id", SVP ?

Merci infiniment de votre aide précieuse.
Anna

 

[anna2054]

Wow, ça marche très bien, apparemment.
Vous avez réussi à garder un seul "name et "address".

Merci infiniment, c'est magnifique ce que vous avez fait, job75
(Je vais vérifier quand même une fois encore...)

 

[anna2054]

Re-bonsoir job75,

- En plus de ce que je viens d'indiquer, la vitesse est très rapide. Merci

- En revanche, il y a une chose bizarre: Dans le résultat, il y a environ 50% des caractères sont en police bold (alors que la source est tout en police normal), et il est impossible de les faire revenir en police normal.
Dans le résultat, les caractères normaux peuvent changer en bold, mais pas inversement, c-a-d les caractères en bold dans le résultat sont inchangeables.
Je ne sais pas pourquoi...

Est-il possible de faire en sorte que tout est en caractère normal, SVP ?

Merci beaucoup.
Anna

 

[job75]

Est-il possible de faire en sorte que tout est en caractère normal, SVP ?

Les caractères en gras sont dus à une MFC, il suffit de ne pas la créer, vous n'aviez pas compris ?

Par ailleurs dimensionner le tableau resu à l'aide de formules Excel n'est pas une bonne idée, il vaut beaucoup mieux utiliser pour cela le Dictionary, voyez ce fichier (2) et la macro définitive :

Private Sub Worksheet_Activate()
Dim d1 As Object, d2 As Object, P As Range, ncol%, tablo, ub&, j%, i&, x$, resu(), lig&, xlig&, n%, decal%
Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = vbTextCompare 'la casse est ignorée
Set d2 = CreateObject("Scripting.Dictionary")
d2.CompareMode = vbTextCompare
Set P = Sheets("Sheet1").[A1].CurrentRegion
ncol = P.Columns.Count
If ncol = 1 Then ncol = 2
P.Columns(ncol).Replace "", "<vide>" 'renseigne les cellules vides
tablo = P.Resize(, ncol) 'matrice, plus rapide, au moins 2 éléments
P.Columns(ncol).Replace "<vide>", "" 'rétablit les cellules vides
'---remplacement de chaque doublon par un espace dans chaque colonne sauf la dernière (facultatif car l'idée est discutable)---
ub = UBound(tablo)
For j = 1 To ncol - 1
    For i = 2 To ub
        x = tablo(i, ncol) & tablo(i, j)
        If d1.exists(x) Then tablo(i, j) = " " Else d1(x) = ""
    Next i
    d1.RemoveAll 'RAZ
Next j
'---dimensionnement du tableau resu---
For i = 2 To ub
    x = tablo(i, ncol)
    d1(x) = d1(x) + 1 'comptage
Next i
If d1.Count = 0 Then d1(0) = 0
ReDim resu(1 To IIf(d1.Count, 2 * d1.Count, 1), 1 To 1 + (ncol - 1) * Application.Max(d1.items))
d1.RemoveAll 'RAZ
'---remplissage du tableau resu---
resu(1, 1) = tablo(1, ncol)
lig = 1
For i = 2 To ub
    x = tablo(i, ncol)
    If Not d1.exists(x) Then
        d1(x) = lig 'mémorise la ligne
        resu(lig + 1, 1) = x
        lig = lig + 2
    End If
    xlig = d1(x) 'récupère la ligne
    d2(x) = d2(x) + 1 'comptage
    n = d2(x)
    decal = (ncol - 1) * (n - 1)
    For j = 1 To ncol - 1
        resu(xlig, 1 + j + decal) = tablo(1, j) & n
        resu(xlig + 1, 1 + j + decal) = tablo(i, j)
Next j, i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
[A3].Resize(UBound(resu), UBound(resu, 2)) = resu 'A3 : 1ère cellule de restitution, à adapter
With UsedRange
    .Columns(1).AutoFit 'ajuste la largeur
    For i = 13 To .Columns.Count Step ncol - 1: .Columns(i).AutoFit: Next 'largeurs pour les adresses
End With
End Sub

 

[anna2054]

Je viens de consulter votre message, vais réessayer ce nouveau macro, et puis vous tiendrai au courant dès que possible.
Merci infiniment, job75.

 

[anna2054]

Bonjour job75,

J'ai essayé mais n'arrive toujours pas à coller le code sur macro.

1. Est ce que je dois garder l'intégralité de votre code ou bien je dois y modifier quelques choses avant de le coller?
Si oui, comment?

2. Quant à "Macro name", est-ce que je peux choisir n'importe quel nom ou il faut un nom précis?
Si oui, lequel?

3. Quant au bouton à cliquer, est-ce que je peux choisir n'importe quel nom du bouton ou il faut un nom précis?
Si oui, lequel?

4. Est-ce que sur le classeur il faut absolument avoir Sheet1 et Sheet2?

C'est la première fois que je fais cette manipulation.
J'utilise Excel 2016, version anglaise.

Merci beaucoup.
Anna

 

[job75]

1. Vous ne devez pas toucher au code mais la structure de votre fichier doit impérativement être la même que celle du fichier post #37.

2. La macro est une macro évènementielle qui se déclenche quand on active la feuille, il ne faut pas modifier la 1ère ligne. Elle doit être dans le code de Sheet2 (clic droit sur l'onglet et Visualiser le code).

3. Il ne faut pas de bouton.

4. Vous pouvez modifier les noms des feuilles mais dans la macro il faudra modifier "Sheet1" à la 7ème ligne.

 

[anna2054]

Je ne comprends pas le point 2:
La feuille "doit être dans le code de Sheet2 (clic droit sur l'onglet et Visualiser le code)", n'est-ce pas?

Merci.

 

[anna2054]

Je pense d'avoir trouvé sur Internet l'instruction nécessaire. Mais après collé le code sur un "module", le sauvegarder et puis ouvrir la macro, j'ai ce message:

"Because of your security settings, macros have been disabled. To run macros, you need to reopen this workbook, and then choose to enable macros."

Comment faire, SVP?

Merci.

 

[anna2054]

(J'ai bien sûr déjà essayé de "enable macro").

 

[job75]

Je ne peux pas vous aider davantage, faites-vous aider par quelqu'un sur votre ordi.

 

[anna2054]

Je comprends, suis très reconnaissante de cette aide très précieuse de votre part.
Vous avez déjà réglé 99% du problème, j'essaie de me débrouiller pour le 1% restant; cela ira tôt ou tard, mais sûrement
Encore, merci infiniment de votre connaissance profonde du sujet et de votre gentillesse, job75.
Bonne fin d'après-midi