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. Je m'y prépare.
Pourrais-je le supprimer après ?
(Je suis neuve sur ce Forum, c'est ma première question).

 

[job75]

On peut toujours éditer un post et supprimer les pièces jointes.

Mais s'il n'y a pas de données confidentielles pourquoi les supprimer ?

Ils seront utiles à ceux qui viendront ultérieurement ici.

 

[anna2054]

Merci.
Pourrais-je vous l'envoyer ce soir ou demain?
(Désolée, je suis occupée :-( )

 

[anna2054]

Bonsoir job75, chris,

Je suis toujours en train de préparer le fichier pour qu'il soit "réel en ne gardant que quelques lignes, sans données confidentielles" comme demandé job75.

Puisqu'il doit être réel, le nombre de paramètres est assez élevé : Bien que je limite le nombre de paramètres principaux à 2, chacun d'entre eux a au moins 3, 4 jusqu'à 10 paramètres (voir plus) en réalité.

En raison de cette complexité, j'ai besoin plus de temps pour que le fichier soit conforme à la demande de job75.

J'essaie de vous l'envoyer un peu tard ce soir.

Encore, merci beaucoup de cette aide précieuse de votre part.

Bonne soirée et à tout à l'heure.
Anna

 

[anna2054]

Veuillez trouver le fichier en pièce jointe.

Une correction : "chacun d'entre eux a au moins 3, 4 (mais quelques fois un seul) jusqu'à 10 paramètres (voir plus) en réalité.".

 

[job75]

L'adaptation de la macro au nouveau fichier n'est pas difficile :

Private Sub Worksheet_Activate()
Dim d1 As Object, d2 As Object, P As Range, ncol%, i&, lig&, x$, xlig&, n%
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
Application.ScreenUpdating = False
Cells.Delete 'RAZ
For i = 1 To ncol - 1: P(1, i) = P(1, i) & "µ": Next 'µ pour la numérotation
lig = 3
P(1, ncol).Copy Cells(lig, 1)
For i = 2 To P.Rows.Count
    x = CStr(P(i, ncol))
    If Not d1.exists(x) Then
        d1(x) = lig 'mémorise la ligne
        Cells(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)
    P(1).Resize(, ncol - 1).Copy Cells(xlig, 2).Offset(, (ncol - 1) * (n - 1))
    Cells(xlig, 2).Offset(, (ncol - 1) * (n - 1)).Resize(, ncol - 1).Replace "µ", n, xlPart
    P(i, 1).Resize(, ncol - 1).Copy Cells(xlig + 1, 2).Offset(, (ncol - 1) * (n - 1))
Next
Columns(1).AutoFit 'ajuste la largeur
For i = 13 To UsedRange.Columns.Count Step ncol - 1: Columns(i).AutoFit: Next 'largeurs pour les adresses
P.Rows(1).Replace "µ", "", xlPart 'retire les µ
End Sub

Je ne comprends pas que vous n'ayez pas présenté ce fichier dès le début.

 

[anna2054]

- Merci beaucoup. Cela marche pour le test.

- "Je ne comprends pas que vous n'ayez pas présenté ce fichier dès le début."
Car cela aurait pris trop de temps.
J'avais essayé de présenter un fichier simplifié, pour voir si ce Forum pourrait me venir en aide (une fois encore, c'est ma 1ère question).

- "L'adaptation de la macro au nouveau fichier n'est pas difficile".
Pour vous, oui certainement.
Pour moi, non :-(
Je vais essayer de l'adapter avec mes réels fichiers demain, et puis vous tiendrai au courant.

- Merci encore, et bonne fin de soirée !

 

[job75]

Bonjour anna2054, le forum,

Les précédentes macros ne sont pas très rapides car elles travaillent sur des cellules.

Pour aller vite il faut utiliser des tableaux VBA, voyez ce fichier (2) et la macro :

Private Sub Worksheet_Activate()
Dim d1 As Object, d2 As Object, P As Range, ncol%, tablo, resu(), i&, lig&, x$, xlig&, n%, decal%, j%
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 'au moins 2 éléménts
If P(1, ncol) = "" Then P(1, ncol) = " "
P.Columns(ncol).Name = "P" 'plage nommée
ThisWorkbook.Names.Add "N", ncol 'nom défini
tablo = P.Resize(, ncol) 'matrice, plus rapide
'ReDim resu(1 To [MAX(1,2*SUM(1/COUNTIF(P,P))-2)], 1 To [1+(N-1)*MAX(COUNTIF(P,P))]) 'ne fonctionne pas toujours
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))])
resu(1, 1) = tablo(1, ncol)
lig = 1
For i = 2 To UBound(tablo)
    x = CStr(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

Le code est plus difficile à comprendre, en particulier pour le dimensionnement du tableau resu.

Notez qu'à la restitution les valeurs textes comme 4.0 sont converties en nombres.

A+

 

[job75]

J'ai un peu modifié la macro avec With UsedRange à la fin.

 

[anna2054]

- Merci beaucoup, job75.
Oui, le dernier est plus rapide, en effet

- Les valeurs identiques sur les champs "name" et "address" se répètent, apparaissent à plusieurs reprises inutilement.
Comment faire en sorte qu'elles apparaissent une seule fois pour chacune des valeurs de "place_id", SVP ?

Merci encore, et bon début d'après-midi.

 

[anna2054]

Re-bonjour job75

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

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]

Bonjour chris,

Les documents que vous m'avez indiqués me sont très utiles pour comprendre de quoi s'agit-il le Power Query. Merci.
Pour information: Quant à ma demande initiale, job75 est en train de m'aider à améliorer le macro.

Bon après-midi.
Anna

OUI

Tu as quelques exemple ici mais pas le tiens exactement
Ce lien n'existe plus

 

[Amilo]

Bonjour,

J'avais une proposition également avec Power query (les titres de colonnes sur une seule ligne) mais comme la demande et le fichier évoluaient je ne pas posté.

Pour information: Quant à ma demande initiale, job75 est en train de m'aider à améliorer le macro.

Sinon j'ai bien noté que job75 est en train de vous aider pour la partie VBA

Cordialement

 

[anna2054]

Merci Amilo. Oui, en effet, le macro créé par job75 fonctionne merveilleusement, sauf un tout petit problème - qui vient du fait que j'ai mal préparé le fichier excel initial :-(

Je viens de lui fournir un nouveau fichier excel initial, attends cette aide de sa part pour corriger ce petit problème.

Merci en tout cas de votre proposition d'aide.

Bon après-midi
Anna

 

[chris]

RE

Alors si tu veux comprendre VBA (car c'est job75 qui fait tout et ne fait pas qu'améliorer...)
ftp:\\ftp-developpez.com\bidou\Cours\VBA\formationVBA.pdf

Edit : bonjour Amilo. J'avais aussi modifié ma requête pour correspondre à la dernière demande (enfin dernière en date...)