Transformation de tableau
Bonjour à tous,
Désolé pour le titre du thread, je n'arrive pas à synthétiser l'idée en quelques mots.
Dans excel 2007, je tente de transformer un tableau.
Le tableau d'origine (à gauche) est généré par un logiciel, mais il n'est pas lisible sous cette forme. Chaque élément possède des dizaines de propriétés (les mêmes pour tous les éléments).
Afin de simplifier la lecture du tableau, j'ai besoin de changer son format.
Les valeurs peuvent être numériques ou textuelles.
J'ai tenté d'utiliser des tableaux croisés dynamiques, sans résultat. J'arrive bien à mettre mon tableau en forme, mais des formules sont systématiquement appliquées sur mes valeurs, ce que je ne veux pas.
Existe-il un moyen plus simple pour réaliser cette transposition?
Je n'ai actuellement "que" 420 lignes à transposer, mais j'en aurais bientôt plusieurs milliers, je souhaite trouver une méthode qui puisse supporter cette montée en volume.
Merci d'avance
Bonjour Guigou, le forum
Vois ceci :
Option Explicit
Sub Ventile()
Dim a, i As Long, j As Long, AL As Object
Set AL = CreateObject("System.Collections.ArrayList")
a = Sheets("Feuil1").Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not AL.Contains(a(i, 1)) Then AL.Add a(i, 1)
If Not .exists(a(i, 2)) Then
Set .Item(a(i, 2)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 2)).CompareMode = 1
End If
.Item(a(i, 2))(a(i, 1)) = a(i, 3)
Next
AL.Sort
ReDim a(1 To .Count + 1, 1 To AL.Count + 1)
a(1, 1) = ""
For i = 0 To AL.Count - 1
a(1, i + 2) = AL(i)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .keys()(i)
For j = 0 To .items()(i).Count - 1
a(i + 2, AL.IndexOf(.items()(i).keys()(j), 0) + 2) = .items()(i).items()(j)
Next
Next
End With
With Sheets("Feuil2").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
.CurrentRegion.ClearContents
.Value = a
.Parent.Select
End With
End Sub
klin89
Salut Klin89, merci pour ta réponse.
Je pars de loin en Excel/VBA, j'ai intégré ce code dans ma feuil1 mais à l'exécution j'obtiens une erreur 9 : "L'indice n'appartient pas à la sélection".
La ligne en problème est "a = Sheets("Feuil1").Cells(1).CurrentRegion.Value"
Je m'y prends sans doute mal
Bonjour,
Tes données doivent commencer en A1.
Cdlt.
Bonjour,
Voir PJ
Sub Stat2DBis()
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Dim a(1 To 100, 1 To 100)
lig = 1
col = 1
Mlig = lig
Mcol = col
For Each c In Range("a2:a" & [A65000].End(xlUp).Row)
If d1.exists(c.Value) Then lig = d1(c.Value) Else d1(c.Value) = Mlig: lig = Mlig: Mlig = Mlig + 1
tmp = c.Offset(, 1)
If d2.exists(tmp) Then col = d2(tmp) Else d2(tmp) = Mcol: col = Mcol: Mcol = Mcol + 1
a(lig, col) = c.Offset(, 2)
Next c
[m2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
[n1].Resize(1, d1.Count) = d1.keys
[n2].Resize(d2.Count, d1.Count) = Application.Transpose(a)
End Sub
Ceuzin
Merci Jean-Eric, effectivement ça fonctionne mieux sans titre de colonne
Merci ceuzin, je vais aussi essayer ton code.
Ayant trouvé ici des gens si sympathiques, je risque de revenir souvent
Re le forum,
Une autre façon de procéder en évitant Application.Transpose
Les données en Feuil1, à partir de A1.
On garde les en-têtes
Restitution à côté du tableau original.
Sub Ventile2()
Dim a, b, i As Long, n As Long, t As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With Sheets("Feuil1").Range("a1").CurrentRegion
a = .Value
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1))
n = 1: t = 1
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not dico.exists(a(i, 2)) Then
n = n + 1: dico(a(i, 2)) = n
b(n, 1) = a(i, 2)
End If
If Not .exists(a(i, 1)) Then
t = t + 1: .Item(a(i, 1)) = t
b(1, t) = a(i, 1)
End If
b(dico(a(i, 2)), .Item(a(i, 1))) = a(i, 3)
Next
End With
'Restitution et mise en forme
With .Offset(, .Columns.Count + 1)
.CurrentRegion.Clear
.Cells(1).Resize(n, t).Value = b
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
With .Rows(1).Offset(, 1).Resize(, .Columns.Count - 1)
.Interior.ColorIndex = 38
.BorderAround Weight:=xlThin
End With
With .Columns(1).Offset(1).Resize(.Rows.Count - 1)
.Interior.ColorIndex = 43
.BorderAround Weight:=xlThin
End With
.Columns.AutoFit
End With
End With
End With
Application.ScreenUpdating = True
End Sub
klin89