Help simplification et organisation de donnees

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Répondre
B
BRU12
Jeune membre
Jeune membre
Messages : 12
Inscrit le : 2 février 2018
Version d'Excel : 2007

Message par BRU12 » 4 février 2018, 18:46

Bonjour,

Je cale sur ce sujet , est ce que qlq aurait une astuce par le biais d'une macro ou autre pour qu'à partir du fichier joint avoir
La ref : en étiquette de ligne
Le Groupe : en étiquette de colonne
Et que le contenu : s'incrémente automatiquement

J'ai essayé par le biais d'un TCD, mais on ne peut pas rentrer de texte , mais seulement des valeurs ....

si qlqn a une astuce . Merci
excel HELP.xlsx
(7.87 Kio) Téléchargé 16 fois
M
MFerrand
Fanatique d'Excel
Fanatique d'Excel
Messages : 17'171
Appréciations reçues : 448
Inscrit le : 20 juillet 2015
Version d'Excel : 2010 FR

Message par MFerrand » 4 février 2018, 20:24

Bonsoir,

Voilà une solution qui m'a l'air de fonctionner...
Sub RéorgTablo()
    Dim tbi, gr, k, d As Object, i%, j%, n%, ref$, tbf()
    tbi = ActiveSheet.Range("A1").CurrentRegion.Value
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(tbi, 1)
        k = tbi(i, 2)
        If InStr(1, gr, k) = 0 Then gr = gr & ";" & k
        k = tbi(i, 1) & "|" & k
        d(k) = tbi(i, 3)
    Next i
    gr = Split(gr, ";")
    ReDim tbf(UBound(gr), 0): tbf(0, 0) = "ref"
    For i = 1 To UBound(gr)
        tbf(i, 0) = gr(i)
    Next i
    Do While d.Count > 0
        For Each k In d.keys
            If ref = "" Then
                ref = Split(k, "|")(0)
                n = n + 1: ReDim Preserve tbf(UBound(gr), n)
                tbf(0, n) = ref
            End If
            If k Like ref & "*" Then
                For i = 1 To UBound(gr)
                    If k = ref & "|" & gr(i) Then
                        tbf(i, n) = d(k)
                        d.Remove (k): Exit For
                    End If
                Next i
            End If
        Next k
        ref = ""
    Loop
    With ActiveSheet.Range("A1")
        .CurrentRegion.ClearContents
        .Resize(n + 1, UBound(gr) + 1).Value = WorksheetFunction.Transpose(tbf)
    End With
End Sub
Je ne garantirai pas son optimalité... je fatigue un peu, et j'ai l'impression d'avoir fait des détours évitables... :lole: mais il convient de voir si elle donne bien le résultat voulu d'une part, puis si c'est OK évaluer le temps qu'elle met sur un tableau de plus grande dimension...

Cordialement.
bru12_excel HELP.xlsm
(19.78 Kio) Téléchargé 8 fois
B
BRU12
Jeune membre
Jeune membre
Messages : 12
Inscrit le : 2 février 2018
Version d'Excel : 2007

Message par BRU12 » 18 février 2018, 21:21

Bonsoir M FERRAND,

Merci pour votre réponse (avec un peu de retard :lol: )
J'aimerai avoir les mêmes connaissance en macro ::o ....

Nous avons testé , mais notre fichier de départ est très très lourd (en nombre de colonnes et de lignes ) du coup , impossible de tester cette macro , l'ordi rame ::( .

Du coup nous, vu que nous ne voulions qu'une base de données , nous avons réussi à "obtenir" une base de données en croisant toutes les données , sur access (oui oui)...

En tout cas mille merci ... Bonne soirée

BRU12
Avatar du membre
Klin89
Membre dévoué
Membre dévoué
Messages : 637
Appréciations reçues : 29
Inscrit le : 28 mai 2011
Version d'Excel : 2003 FR

Message par Klin89 » 18 février 2018, 21:58

Bonsoir MFerrand, BRU12, le forum :)

Tu peux essayer celle-ci
Il faut créer manuellement Feuil2 au préalable
Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, t As Long, dico1 As Object, dico2 As Object
    Set dico1 = CreateObject("Scripting.Dictionary")
    dico1.CompareMode = 1
    Set dico2 = CreateObject("Scripting.Dictionary")
    With Sheets("feuil1").Range("a1").CurrentRegion
        a = .Value: ReDim b(1 To UBound(a, 1), 1 To 10)
        n = 1: t = 1
        For i = 2 To UBound(a, 1)
            If Not dico1.exists(a(i, 2)) Then
                t = t + 1
                dico1(a(i, 2)) = t
                If UBound(b, 2) < t Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 50)
                End If
                b(1, t) = a(i, 2)
            End If
            If Not dico2.exists(a(i, 1)) Then
                n = n + 1
                dico2(a(i, 1)) = n
                b(n, 1) = a(i, 1)
            End If
            b(dico2(a(i, 1)), dico1(a(i, 2))) = a(i, 3)
        Next
    End With
    Application.ScreenUpdating = False
    'restitution et mise en forme
    With Sheets("Feuil2").Range("a1")
        .CurrentRegion.Clear
        With .Resize(n, t)
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .HorizontalAlignment = xlCenter
                With .Offset(, 1).Resize(, .Columns.Count - 1)
                    .Interior.ColorIndex = 44
                End With
            End With
            With .Columns(1)
                .HorizontalAlignment = xlCenter
                With .Offset(1).Resize(.Rows.Count - 1)
                    .Interior.ColorIndex = 36
                End With
            End With
            .Columns.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
    Set dico1 = Nothing: Set dico2 = Nothing
End Sub
klin89
Répondre
  • Sujets similaires
    Réponses
    Vues
    Dernier message