XL 2016 Reporting depuis un tableau

[loicoss]

Bonjour,

Je souhaiterai effectué un reporting d'un tableau Excel, exporté depuis un logiciel (mise en forme prédéfinie).

Les données que je souhaite synthétiser, sont :
- identifier chaque client
- pour chaque client faire ressortir les codes associés
- les clients peuvent avoir plusieurs fois le même code, du coup je souhaiterai les compter.

dans les cellules intervenants, il peut y avoir plusieurs clients séparés par des points virgues (

J'ai essayé de répondre à mon besoin avec différentes formules, mais je n'y arrive pas (RECHERCHEV; NB.SI, etc.)

Pourriez-vous m'aider svp sur ce sujet par un jeu de formules ou éventuellement une macro ?

Je vous joins un fichier avec en onglet "Actes" le tableau et en onglet "Reporting" la synthèse que je souhaiterai.

S'il était possible d'avoir cette synthèse avec une mise en forme et le nom des colonnes.

Je vous remercie par avance pour le coup de main.

Bonne journée.

 

[chris]

Bonjour

Avec 2016 c'est faisable en quelques clics par PowerQuery intégré à Excxel mais il vaudrait mieux partir directement de l'extraction

Est-ce un fichier csv ?

 

[loicoss]

Bonjour

Avec 2016 c'est faisable en quelques clics par PowerQuery intégré à Excxel mais il vaudrait mieux partir directement de l'extraction

Est-ce un fichier csv ?

Bonsoir et merci pour votre réponse.

Je ne connais PowerQuery mais je suis preneur d’information.
L’extraction du fichier est au format .xlsx

 

[chris]

RE

Une solution ci-joint : modifier le chemin et nom du fichier (en respectant la casse) et Données, Actualiser Tout

 

[job75]

Bonsoir loicoss, chris,

Une solution VBA, voyez le fichier joint et cette macro dans le code de la feuille "Reporting" :

Private Sub Worksheet_Activate()
Dim d As Object, dest As Range, tablo, i&, s, x$, j%, y$, z$, a, b
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set dest = [B3] '1ère cellule du tableau des résultats
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
dest(2).Resize(Rows.Count - dest.Row, 3).Delete xlUp 'RAZ
'---1er traitement---
tablo = Feuil1.[A2].CurrentRegion.Columns(3).Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    s = Split(tablo(i, 1), ";")
    x = tablo(i, 3)
    For j = 0 To UBound(s)
        y = Trim(s(j))
        If y <> "" Then
            z = x & Chr(1) & y
            d(z) = d(z) + 1 'comptage
        End If
Next j, i
If d.Count = 0 Then GoTo 1
a = d.keys: b = d.items
'---1ère restitution---
ReDim tablo(UBound(a), 2) 'base 0
For i = 0 To UBound(a)
    s = Split(a(i), Chr(1))
    tablo(i, 0) = s(1)
    tablo(i, 1) = s(0)
    tablo(i, 2) = b(i)
Next i
dest(2).Resize(i, 3) = tablo
dest(2).Resize(i, 3).Sort dest, xlAscending, dest(1, 2), , xlAscending, Header:=xlNo 'tri sur 2 colonnes
'---2ème traitement pour effacer les doublons---
a = dest.Resize(i + 1) 'matrice, plus rapide
tablo = a
For i = 2 To UBound(a)
    If LCase(a(i, 1)) = LCase(a(i - 1, 1)) Then tablo(i, 1) = ""
Next i
'---2ème restitution---
dest.Resize(i - 1) = tablo
'---bordures---
dest(1, 2).Resize(i - 1, 2).Borders.Weight = xlThin
dest.Resize(i - 1).BorderAround Weight:=xlThin 'pourtour
With dest.Resize(i - 1).SpecialCells(xlCellTypeConstants)
    .Borders(xlEdgeTop).Weight = xlThin
    .Borders(xlInsideHorizontal).Weight = xlThin
End With
1 With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Elle se déclenche quand on active la feuille.

Elle est très rapide car elle utilise des tableaux VBA et le Dictionary.

Nota : j'ai testé l'application des bordures avec SpecialCells.

Pas de problème sur 100 000 lignes mais sur 1 000 000 lignes ça prend beaucoup de temps.

A+

 

[loicoss]

Bonjour,

merci pour cette aide.
Je vais tester tout ça dès demain.
Le code VBA me plait bien je l’associerai plutôt avec un bouton.

je vous tiens au courant.
Encore merci

Bonne journée.

 

[job75]

Bonjour loicoss,

Dans ce fichier (2) la macro est affectée à un bouton.

Et les bordures sont appliquées par 2 MFC, sauf le pourtour qui reste appliqué par la macro.

Cela évite tout problème s'il y a 1 000 000 de lignes

A+

 

[loicoss]

Merci pour ton retour, je vais regarder ça de près dès demain

 

[loicoss]

Bonjour à vous,

Vos 2 propositions fonctionnent et répondent à ma demande.
Je vous remercie pour votre aide.

 

[loicoss]

Bonjour à tous,



J'ouvre à nouveau ce sujet car cette première étape ne répond pas totalement à mon besoin.


En fait, l'extraction brute de mon fichier me donne 3 onglets différents que je souhaite combiner.


Le résultat attendu se trouve dans l'onglet "Reporting".


Sachant que la difficulté est que dans 2 des onglets les intervenants apparaissent l'un pour son résultat de méthode et l'autre pour l'UO.


à noter également que le point commun de ces trois onglet est le numéro.


J'ai essayé en dehors des macros de faire cette synthèse avec Power Query mais je ne m'en sors pas.

Mon besoin final est pour chaque intervenant d'avoir pour un même numéro, la date, le responsable, la méthode et le nombre d'UO


En vous remerciant pour votre précieuse aide.

 

[chris]

Bonjour

Remplis au moins 3 lignes du reporting car sans plus d'infos...

 

[job75]

Bonsoir loicoss, chris,

Voyez le fichier joint et la macro du bouton :

Sub MAJ()
Dim ncol%, d As Object, tablo, i&, x$, s, j%, y$, z$, n&, resu(), lig&
ncol = 8 'nombre de colonnes des résultats
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignoré
'---feuille Methodes---
tablo = Sheets("Methodes").[A2].CurrentRegion.Resize(, 4) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    s = Split(tablo(i, 3), ";")
    For j = 0 To UBound(s)
        y = Trim(s(j))
        If y <> "" Then
            z = x & y
            If Not d.exists(z) Then
                n = n + 1
                d(z) = n 'mémorise la ligne
                ReDim Preserve resu(1 To ncol, 1 To n)
                resu(1, n) = x 'Numéro
                resu(4, n) = y 'Intervenant
                y = LCase(tablo(i, 4))
                resu(IIf(y = "air", 5, IIf(y = "sol", 7, 6)), n) = y 'Méthode
            End If
        End If
Next j, i
'---feuille Actes---
tablo = Sheets("Actes").[A2].CurrentRegion.Resize(, 5) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    s = Split(tablo(i, 3), ";")
    For j = 0 To UBound(s)
        y = Trim(s(j))
        If y <> "" Then
            z = x & y
            If Not d.exists(z) Then
                n = n + 1
                d(z) = n 'mémorise la ligne
                ReDim Preserve resu(1 To ncol, 1 To n)
                resu(1, n) = x 'Numéro
                resu(4, n) = y 'Intervenant
            End If
            resu(8, d(z)) = tablo(i, 5) 'UO
        End If
Next j, i
'---feuilles Bons---
d.RemoveAll 'RAZ
tablo = Sheets("Bons").[A2].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    If Not d.exists(x) Then d(x) = i 'mémorise la ligne
Next i
For i = 1 To n
    x = resu(1, i)
    If d.exists(x) Then
        lig = d(x)
        If IsDate(tablo(lig, 2)) Then resu(2, i) = CDate(tablo(lig, 2)) Else resu(2, i) = tablo(lig, 2)
        resu(3, i) = tablo(lig, 3)
    End If
Next i
'---transposition---
If n Then
    ReDim tablo(1 To n, 1 To ncol)
    For i = 1 To n
        For j = 1 To ncol
            tablo(i, j) = resu(j, i)
    Next j, i
End If
'---restitution---
With Sheets("Reporting")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A4]
        If n Then
            .Resize(n, ncol) = tablo
            .Resize(n, ncol).Borders.Weight = xlThin 'bordures
        End If
        .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

A+

 

[loicoss]

Bonsoir Chris et Bonsoir Job75

Voici ma pièce jointe modifiée avec mon souhait de résultat par rapport aux différents onglets.
J'ai pris 3 exemples (3 couleurs différentes).

Merci à vous.

 

[chris]

RE

Un essai PowerQuery

Peux-être faut-il dédoublonner...

 

[job75]

Si vous passez votre temps à modifier votre fichier on ne va pas s'en sortir.

Fichier (2) avec la nouvelle macro :

Sub MAJ()
Dim ncol%, d As Object, tablo, i&, x$, s, j%, y$, z$, n&, resu(), lig&
ncol = 6 'nombre de colonnes des résultats
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignoré
'---feuille Methodes---
tablo = Sheets("Methodes").[A2].CurrentRegion.Resize(, 4) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    s = Split(tablo(i, 3), ";")
    For j = 0 To UBound(s)
        y = Trim(s(j))
        If y <> "" Then
            z = x & y
            If Not d.exists(z) Then
                n = n + 1
                d(z) = n 'mémorise la ligne
                ReDim Preserve resu(1 To ncol, 1 To n)
                resu(1, n) = x 'Numéro
                resu(4, n) = y 'Intervenant
                resu(5, n) = Application.Proper(tablo(i, 4)) 'Méthode
            End If
        End If
Next j, i
'---feuille Actes---
tablo = Sheets("Actes").[A2].CurrentRegion.Resize(, 5) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    s = Split(tablo(i, 3), ";")
    For j = 0 To UBound(s)
        y = Trim(s(j))
        If y <> "" Then
            z = x & y
            If Not d.exists(z) Then
                n = n + 1
                d(z) = n 'mémorise la ligne
                ReDim Preserve resu(1 To ncol, 1 To n)
                resu(1, n) = x 'Numéro
                resu(4, n) = y 'Intervenant
            End If
            resu(6, d(z)) = tablo(i, 5) 'UO
        End If
Next j, i
'---feuille Bons---
d.RemoveAll 'RAZ
tablo = Sheets("Bons").[A2].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    If Not d.exists(x) Then d(x) = i 'mémorise la ligne
Next i
For i = 1 To n
    x = resu(1, i)
    If d.exists(x) Then
        lig = d(x)
        If IsDate(tablo(lig, 2)) Then resu(2, i) = CDate(tablo(lig, 2)) Else resu(2, i) = tablo(lig, 2)
        resu(3, i) = tablo(lig, 3)
    End If
Next i
'---transposition---
If n Then
    ReDim tablo(1 To n, 1 To ncol)
    For i = 1 To n
        For j = 1 To ncol
            tablo(i, j) = resu(j, i)
    Next j, i
End If
'---restitution---
With Sheets("Reporting")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A3]
        If n Then
            .Resize(n, ncol) = tablo
            .Resize(n, ncol).Borders.Weight = xlThin 'bordures
        End If
        .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

Nota : dans la feuilles "Actes" lignes 3 et 4 il y a doublons, la macro retient uniquement le 2ème UO.