Simplification et organisation de donnees
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
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...
Cordialement.
Bonsoir M FERRAND,
Merci pour votre réponse (avec un peu de retard
J'aimerai avoir les mêmes connaissance en macro
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
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