XL 2019 croisé dynamique - macro

ZENHA ENT · 14 Juin 2022

Bonsoir,

J'espère que vous allez bien

Je souhaiterai obtenir un TABLEAU à partir des données saisie dans la feuille "donnée ", j'ai essayé avec les croisés dynamique mais je n'ai pas réussi, peut être que c'est faisable avec une macro ou même avec un croisé dynamique avancé (je n'arrive pas à faire ca avec plusieurs parc et plusieurs zones ) ! le résultat que j'essaye d'obtenir est sur la feuille "résultat attendu"
quelqu'un parmi vous peut me donner un coup de main sur le fichier ci-joint et merci d'avance

Cordialement,

job75 · 14 Juin 2022

"ASP" n'est pas le même parc que "as" mais bon pour obtenir le résultat que vous voulez il suffit de trier alphabétiquement le tableau des résultats.

Par ailleurs dans certains cas il est indispensable d'encadrer les noms des machines pour la recherche.

Voyez ce fichier (2) et la macro :

VB:

Private Sub Worksheet_Activate()
Dim d As Object, tablo, i&, x$, y$, n&, dest As Range
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignotée
tablo = Sheets("DONNEE").[A1].CurrentRegion.Resize(, 13) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 13) & Chr(1) & tablo(i, 11) 'concaténation avec séparateur
    y = tablo(i, 5)
    If d.exists(x) Then
        If y <> "" Then If...

JHA · 14 Juin 2022

Bonjour à tous,

A essayer

JHA

job75 · 14 Juin 2022

Bonjour ZENHA ENT, JHA,

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" :

VB:

Private Sub Worksheet_Activate()
Dim d As Object, tablo, i&, x$, y$, n&, dest As Range
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignotée
tablo = Sheets("DONNEE").[A1].CurrentRegion.Resize(, 13) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 13) & Chr(1) & tablo(i, 11) 'concaténation avec séparateur
    y = tablo(i, 5)
    If d.exists(x) Then
        If y <> "" Then If InStr(d(x), y) = 0 Then d(x) = d(x) & Chr(1) & y
    Else
        If y <> "" Then d(x) = y
    End If
Next
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
Set dest = [A1] '1ère cellule, à adapter
dest = "PARC": dest(1, 2) = "ZONE": dest(1, 3) = "MACHINE"
n = d.Count
If d.Count = 0 Then Exit Sub
dest(2).Resize(n) = Application.Transpose(d.keys) 'attention, Transpose est limitée à 65536 lignes
dest(2).Resize(n).TextToColumns dest(2), xlDelimited, Other:=True, OtherChar:=Chr(1) 'commande Convertir
dest(2, 3).Resize(n) = Application.Transpose(d.items)
dest(2, 3).Resize(n).TextToColumns dest(2, 3), xlDelimited, Other:=True, OtherChar:=Chr(1)
With dest(1, 3).Resize(, dest.CurrentRegion.Columns.Count - 2)
    .Merge 'fusionne
    .HorizontalAlignment = xlCenter 'centre
    .Select
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub

Elle se déclenche automatiquement quand on active la feuille.

A+

ZENHA ENT · 14 Juin 2022

Bonjour monsieur ,
Alors la rien à dire, le fichier tourne très bien, je vous remercie énormément,
le seul soucis c'est que les machines qui sont dans le même parc doivent être afficher l'une en dessous de l'autre, le fichier ci joint vous donnera plus d'explications.
Merci encore une fois et bonne journée

job75 · 14 Juin 2022

"ASP" n'est pas le même parc que "as" mais bon pour obtenir le résultat que vous voulez il suffit de trier alphabétiquement le tableau des résultats.

Par ailleurs dans certains cas il est indispensable d'encadrer les noms des machines pour la recherche.

Voyez ce fichier (2) et la macro :

VB:

Private Sub Worksheet_Activate()
Dim d As Object, tablo, i&, x$, y$, n&, dest As Range
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignotée
tablo = Sheets("DONNEE").[A1].CurrentRegion.Resize(, 13) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    x = tablo(i, 13) & Chr(1) & tablo(i, 11) 'concaténation avec séparateur
    y = tablo(i, 5)
    If d.exists(x) Then
        If y <> "" Then If InStr(Chr(1) & d(x) & Chr(1), Chr(1) & y & Chr(1)) = 0 Then d(x) = d(x) & Chr(1) & y 'encadrement du nom de la machine
    Else
        If y <> "" Then d(x) = y
    End If
Next
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
Set dest = [A1] '1ère cellule, à adapter
dest = "PARC": dest(1, 2) = "ZONE": dest(1, 3) = "MACHINE"
n = d.Count
If n = 0 Then Exit Sub
dest(2).Resize(n) = Application.Transpose(d.keys) 'attention, Transpose est limitée à 65536 lignes
dest(2).Resize(n).TextToColumns dest(2), xlDelimited, Other:=True, OtherChar:=Chr(1) 'commande Convertir
dest(2, 3).Resize(n) = Application.Transpose(d.items)
dest.Resize(n + 1, 3).Sort dest, xlAscending, Header:=xlYes 'tri alphabétique sur PARC
dest(2, 3).Resize(n).TextToColumns dest(2, 3), xlDelimited, Other:=True, OtherChar:=Chr(1)
With dest(1, 3).Resize(, dest.CurrentRegion.Columns.Count - 2)
    .Merge 'fusionne
    .HorizontalAlignment = xlCenter 'centre
    .Select
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub

ZENHA ENT · 14 Juin 2022

impeccable , cela va beaucoup m'aider dans mon stage ,
Je vous souhaite une excellente journée
Cordialement

ZENHA ENT · 21 Juin 2022

Bonjour monsieur,
j'ai un petit soucis sur la macro c'est que les résultat doivent prendre en compte les valeurs qui sont dans la colonne S ci il s'agit d'un 0 j'envoi pas de résultat, je restitue quand il s'agit de 1 uniquement ,exemple joint.
Merci d'avance pour votre aide

job75 · 21 Juin 2022

Bonjour ZENHA ENT, le forum,

Il suffit de tester la colonne S (19), voyez ce fichier (3) :

VB:

tablo = Sheets("DONNEE").[A1].CurrentRegion.Resize(, 19) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If tablo(i, 19) = 1 Then 'colonne S

A+

ZENHA ENT · 21 Juin 2022

merci beaucoup pour l'effort, j'ai une dernière demande mais je sais pas si vous allez arriver j'ai passé prés de 4 heures sans arriver en faite je souhaite rajouter des couleurs au machine dans la feuille résultat attendue ,dans la colonne G de la feuille "donnée" j'ai 4 paramètres "be,en,fe,ze" je souhaite appliqué les couleurs dans le feuille résultat attendu sur la colonne machine sachant que les cellules ne sont pas colorée dans la feuille "donnée" cela est il possible svp?
UN EXEMPLE EST CI-JOINT
cordialement,

job75 · 21 Juin 2022

Vous ne tenez plus compte de la colonne S.

Et en plus des lignes sont masquées par filtrage dans la feuille source, c'est n'importe quoi.

ZENHA ENT · 21 Juin 2022

désolé je me suis peut être mal exprimé, mon critère de choix est la colonne 'G' je dois avoir des couleurs par rapport à cette colonnes en prenant la colonne S en charge aussi, j'espère que vous avez compris !
des explications sont ci- joint, feuille 'résultat attendu' et 'DONNEE'

job75 · 21 Juin 2022

Voyez ce fichier (4) et la macro qui permet d'obtenir le résultat que vous souhaitez :

VB:

Private Sub Worksheet_Activate()
Dim d As Object, r As Range, tablo, i&, x$, y$, z$, n&, dest As Range, s
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignotée
Set r = Sheets("DONNEE").[A1].CurrentRegion.Resize(, 19)
tablo = r 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If tablo(i, 19) = 1 Then 'colonne S
        If Not r.Rows(i).Hidden Then 'lignes non masquées
            x = tablo(i, 13) & Chr(1) & tablo(i, 11) 'concaténation avec séparateur
            y = tablo(i, 5)
            If y <> "" Then
                y = r(i, 7).Interior.Color & Chr(2) & y 'concatène le code couleur
                If d.exists(x) Then
                    If InStr(Chr(1) & d(x) & Chr(1), Chr(1) & y & Chr(1)) = 0 Then d(x) = d(x) & Chr(1) & y 'encadrement du nom de la machine
                Else
                    d(x) = y
                End If
            End If
        End If
    End If
Next i
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
Set dest = [A1] '1ère cellule, à adapter
dest = "PARC": dest(1, 2) = "ZONE": dest(1, 3) = "MACHINE"
n = d.Count
If n = 0 Then Exit Sub
dest(2).Resize(n) = Application.Transpose(d.keys) 'attention, Transpose est limitée à 65536 lignes
dest(2).Resize(n).TextToColumns dest(2), xlDelimited, Other:=True, OtherChar:=Chr(1) 'commande Convertir
dest(2, 3).Resize(n) = Application.Transpose(d.items)
dest.Resize(n + 1, 3).Sort dest, xlAscending, Header:=xlYes 'tri alphabétique sur PARC
dest(2, 3).Resize(n).TextToColumns dest(2, 3), xlDelimited, Other:=True, OtherChar:=Chr(1)
With dest(1, 3).Resize(, dest.CurrentRegion.Columns.Count - 2)
    .Merge 'fusionne
    .HorizontalAlignment = xlCenter 'centre
    .Select
End With
'---colore les cellules---
For Each r In UsedRange
    s = Split(r, Chr(2))
    If UBound(s) = 1 Then
        r.Interior.Color = s(0)
        r = s(1) 'supprime le code couleur
    End If
Next r
End Sub

ZENHA ENT · 21 Juin 2022

Super ! mais ce qu'il manque ici c'est comment donné les couleurs à la colonne G c'est à dire si c'est Xl sa doit etre "orange" si ent " rouge" ze "jaune" ....
Merci d'avance

job75 · 21 Juin 2022

Si vous ne connaissez pas les mises en forme conditionnelles (MFC) renseignez-vous.

Dans ce fichier (5) j'en ai créé une avec 3 conditions en colonne G.

Pour que ses couleurs puissent être restituées dans la feuille "Résultat" il faut utiliser DisplayFormat :

VB:

y = r(i, 7).DisplayFormat.Interior.Color & Chr(2) & y 'concatène le code de la couleur donnée par la MFC

ZENHA ENT · 21 Juin 2022

c'est extraordinaire merci, j'essaye d'appliquer ce code dans une macro mais il beug je ne comprends pas pourquoi, malgré qu'il fonctionne trés bien avec l'activation automatique

XL 2019 croisé dynamique - macro

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

Pièces jointes

Discussions similaires