Comptage fractionnaire occurrence

Bonjour à tous,

Fichier ci-joint,

Je cherche à partir des données brutes en formes colonne A-B à réaliser un comptage de l'association de la donnée en colonne A avec celle en colonne B.

J'ai déjà le programme pour fractionner la chaine en lignes, sans éliminer les doublons, et mettre chaque élément de la colonne A en fonction de chacune de ses possibilités, mais il me manque le comptage qui me donnera la somme d’occurrences de l'association(i).

Sub supprime_les_lignes_avec_zero()

Dim i As Integer 
    For i = Range("A65000").End(xlUp).Row To 1 Step -1 'ajuster la plage de la liste à traiter        
        If Range("A" & i) = "" Then 'autant de test if qu'il y a de colonne, remplace L par G...
        Range("A" & i).EntireRow.Delete
        End If
Next
End Sub

Sub casser_chaine_decliner_verticalement()
Dim a, b(), i As Long, j As Long, x, n As Long, k As String
    With Sheets(2).Range("a2").CurrentRegion 'définition du point de départ du tableau à traiter avec current region
       a = .Value
        'attention à la 1ère dimension
      ReDim b(1 To UBound(a, 1) * 10, 1 To UBound(a, 2))
        For i = 1 To UBound(a, 1)
            x = Split(a(i, 2), ";") '6 c'est le n° de la colonne de la cellule à éclater
           For j = 0 To UBound(x)
                n = n + 1
                b(n, 1) = a(i, 1): b(n, 2) = a(i, 2)
                b(n, 2) = x(j)
            Next
        Next
        .Offset(, .Columns.Count + 1).Resize(n).Value = b
    End With
End Sub

Si quelqu'un a une solution (en vba), merci par avance.

Je sais que le comptage se fait très par TableauCroiséDynamique, mais j'aimerai un code

G.

NB : Voici des éléments que j'ai déjà pour faire des transposition matricielle et des glissements de décomptes.

Sub Transpose_produit_fonction()
    Dim Tbl()
    Dim I As Integer 
    'appel de la fonction
   Tbl() = TransposeGrille(Range("B2:O27"))
    'inscrit à partir de C20. Attention, les titres ne sont pas inscrits (Item1 et Item2)
   Range("Q1").Resize(UBound(Tbl, 1), UBound(Tbl, 2)) = Tbl
End Sub

Function TransposeGrille(Plage As Range) As Variant() 'la fonction retourne un tableau  
    Dim Tbl()
    Dim Cel As Range
    Dim I As Long
    Dim J As Long

    For Each Cel In Plage.Columns(1).Cells
        For I = 1 To Plage.Columns.Count - 1
            If Cel.Offset(, I).Value = 1 Then
                J = J + 1
                ReDim Preserve Tbl(1 To 2, 1 To J)               
                Tbl(1, J) = Cel.Value
                Tbl(2, J) = Plage(1, 1 + I).Value

            End If
        Next I
    Next Cel  
    TransposeGrille = Application.WorksheetFunction.Transpose(Tbl())
End Function

Pour passer d'une structure matricielle à 2 dimensions, vers une table verticale exhaustives des relations.

Sub Transpose_fonction_arcs()

    Dim Tbl()
    Dim I As Integer

    'appel de la fonction
   Tbl() = TransposeGrille(Range("B17:F21"))

    'inscrit à partir de C20. Attention, les titres ne sont pas inscrits (Item1 et Item2)
   Range("F36").Resize(UBound(Tbl, 1), UBound(Tbl, 2)) = Tbl

End Sub

Function TransposeGrille(Plage As Range) As Variant() 'la fonction retourne un tableau

    Dim Tbl()
    Dim Cel As Range
    Dim I As Long
    Dim J As Long

    For Each Cel In Plage.Columns(1).Cells

        For I = 1 To Plage.Columns.Count - 1

            If Cel.Offset(, I).Value <> 0 Then

                J = J + 1
                ReDim Preserve Tbl(1 To 2, 1 To J)

                Tbl(1, J) = Cel.Value
                Tbl(2, J) = Plage(1, 1 + I).Value

            End If

        Next I

    Next Cel

    TransposeGrille = Application.WorksheetFunction.Transpose(Tbl())

End Function

Même chose en utilisant les sous-totaux pour chaque relation pour faire le compte finale à chaque relation

G.

Salut

est ce que les données doit etres trier ?

Le mieux c'est que le rendu soit trié sur colonne A, de A à Z oui.

G.

Bonsoir Pwetzou, AMIR, le forum

Vois ceci :

Feuil1, j'ai effacé le contenu de la cellule H2, pour ne pas fausser le résultat.

Je m'appuie donc sur le tableau commençant en H3

Restitution en Feuil2

Option Explicit

Sub test()
Dim a, i As Long, w(), n, y
    With Sheets("Feuil1").Range("h3").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    Set .Item(a(i, 1)) = _
                    CreateObject("Scripting.Dictionary")
                End If
                If Not .Item(a(i, 1)).exists(a(i, 2)) Then
                    ReDim w(1 To 3)
                    w(1) = a(i, 1): w(2) = a(i, 2): w(3) = 1
                    .Item(a(i, 1))(a(i, 2)) = w
                Else
                    w = .Item(a(i, 1))(a(i, 2))
                    w(3) = w(3) + 1
                    .Item(a(i, 1))(a(i, 2)) = w
                End If
            Next
            y = .items
        End With
        Application.ScreenUpdating = False
        'Restitution
        With Sheets("Feuil2")
            .Cells.Clear
            With .Cells(1)
                For i = 0 To UBound(y)
                    With .Offset(n).Resize(y(i).Count, 3)
                        .Value = _
                        Application.Transpose(Application.Transpose(y(i).items))
                        n = n + .Rows.Count
                    End With
                Next
                With .CurrentRegion
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .VerticalAlignment = xlCenter
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                End With
            End With
            .Activate
        End With
        Application.ScreenUpdating = True
    End With
End Sub

klin89

Ca marche super bien..

Je vais me décomposer ça, car c'est un peu violent (heureusement y'a les tutos sur les tableaux pour comprendre).

J'ai réadapté le programme pour s'exécuter en A2.currentregion et sans recopier en feuil2, mais en restant sur la feuille initiale (Resize)

2 questions cependant :

- Pourquoi emploies-tu cela :

With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
...
...
y = .items

- et cela :

.Cells.Clear
...
...

.Activate

Merci encore Klin89...,

G.

bon, j'ai compris le point #2 (nettoyage de la feuille).

.Cells.Clear
...
...

.Activate

mais le point #1 reste un mystère :p

G.

Re Pwetzou

Le code réajusté :

Option Explicit

Sub test()
Dim a, i As Long, w(), n, y
    With Sheets("Feuil1").Range("h3").CurrentRegion
        a = .Value
        'la plus simple façon de créer un dictionnaire
        With CreateObject("Scripting.Dictionary")
            'ne tient pas compte de la casse
            .CompareMode = 1
            'tient compte de la casse
            '.CompareMode = 0
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    Set .Item(a(i, 1)) = _
                    CreateObject("Scripting.Dictionary")
                End If
                If Not .Item(a(i, 1)).exists(a(i, 2)) Then
                    ReDim w(1 To 3)
                    w(1) = a(i, 1): w(2) = a(i, 2)
                Else
                    w = .Item(a(i, 1))(a(i, 2))
                End If
                w(3) = w(3) + 1
                .Item(a(i, 1))(a(i, 2)) = w
            Next
           'récupère tous les éléments stockés de l'objet dictionnaire
           'dans la variable tableau y
            y = .items
        End With
        Application.ScreenUpdating = False
        'Restitution
        With Sheets("Feuil2")
            .Cells.Clear
            With .Cells(1)
                For i = 0 To UBound(y)
                    With .Offset(n).Resize(y(i).Count, 3)
                        .Value = _
                        Application.Transpose(Application.Transpose(y(i).items))
                        n = n + .Rows.Count
                    End With
                Next
                With .CurrentRegion
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .VerticalAlignment = xlCenter
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                End With
            End With
            .Activate
        End With
        Application.ScreenUpdating = True
    End With
End Sub

klin89