TCD sans calcul
Tu peux essayer cette macro (lancer la procédure ListeVersTableau). Cette procédure construit sur une nouvelle feuille un tableau à partir de la plage sélectionnée (3 colonnes). Les colonnes de cette plage servent à fabriquer le tableau de la manière suivante:
Colonne de gauche => champ "ligne" du tableau
Colonne centrale => champ "colonne" du tableau
Colonne de droite => contenu du tableau (intersections lignes-colonnes)
Dim Arr, Idx() As Long Dim Elt, IdxTemp As Long Dim I As Long, NElts As Long
sub ListeVersTableau()
Dim Plage As Range
Dim ArrC, ArrL, ArrElt
Dim ArrCF, ArrLF, ArrEltF
Dim Lignes As Long, Cols As Long
On Error Resume Next
Do
Set Plage = Application.InputBox("Sélectionner la plage de " & _
"données (sans les en-têtes) à transformer en tableau.", Type:=8)
If Plage Is Nothing Then exit sub
If Plage.Columns.Count = 3 Then Exit Do
If MsgBox("La plage doit comporter 3 colonnes.", _
vbInformation + vbOKCancel) = vbCancel Then exit sub
Loop
On Error GoTo 0
ArrC = Plage.Columns(1)
ArrL = Plage.Columns(2)
NElts = UBound(ArrC)
Tri ArrC, ArrCF
Tri ArrL, ArrLF
ArrElt = Plage.Columns(3)
Lignes = UBound(ArrCF)
Cols = UBound(ArrLF)
ReDim ArrEltF(1 To Lignes, 1 To Cols)
With Application
For I = 1 To NElts
ArrEltF(.Match(ArrC(I, 1), ArrCF), _
.Match(ArrL(I, 1), ArrLF)) = ArrElt(I, 1)
Next I
End With
Application.ScreenUpdating = False
Worksheets.Add After:=Plage.Worksheet
With [A2].Resize(Lignes)
.Value = Application.Transpose(ArrCF)
.Font.Bold = True
End With
With [B1].Resize(, Cols)
.Value = ArrLF
.Font.Bold = True
End With
[B2].Resize(Lignes, Cols) = ArrEltF
With [B2].CurrentRegion
.EntireColumn.AutoFit
.Select
End With
end subPrivate sub Tri(NonTrié, Trié) Dim J As Integer ReDim Idx(1 To NElts) For I = 1 To NElts Idx(I) = I Next I Arr = NonTrié Recurse 1, NElts ReDim Trié(1 To NElts) Trié(1) = Arr(Idx(1), 1) J = 1 For I = 2 To NElts If Arr(Idx(I), 1) <> Arr(Idx(I - 1), 1) Then J = J + 1 Trié(J) = Arr(Idx(I), 1) End If Next I Erase Arr ReDim Preserve Trié(1 To J) end sub
Private sub Recurse(ByVal B1 As Long, ByVal H1 As Long) Dim B2 As Long Dim H2 As Long B2 = B1 H2 = H1 Elt = Arr(Idx((B1 + H1) \ 2), 1) Do While B2 < H2 Do While B2 < H1 And Arr(Idx(B2), 1) < Elt B2 = B2 + 1 Loop Do While H2 > B1 And Arr(Idx(H2), 1) > Elt H2 = H2 - 1 Loop If B2 < H2 Then IdxTemp = Idx(B2) Idx(B2) = Idx(H2) Idx(H2) = IdxTemp End If If B2 <= H2 Then B2 = B2 + 1 H2 = H2 - 1 End If Loop If H2 > B1 Then Recurse B1, H2 If B2 < H1 Then Recurse B2, H1 end sub
Et pour faire l'inverse ? C'est à dire reconstruire une liste en 3 colonnes à partir d'un tableau style TCD : Essaie cette macro. Elle suppose que ton tableau commence dans la cellule A1 de la feuille active et que la 1ere colonne ait un en-tête ("Article" dans la cellule A1).
sub TableauEnListe()
Dim TCD As PivotTable, P As Range
Dim RField, DFields, DField
Application.ScreenUpdating = False
RField = [A1]
DFields = Range("B1", [B1].End(xlToRight))
Set TCD = ThisWorkbook.PivotCaches.Add(xlDatabase, [A1]. _
CurrentRegion.Address(ReferenceStyle:=xlR1C1)).CreatePivotTable("")
TCD.AddFields RField
For Each DField In DFields
TCD.PivotFields(DField).Orientation = xlDataField
Next DField
TCD.ColumnGrand = False
With TCD.TableRange2
.Copy
.PasteSpecial xlPasteValues
.ClearFormats
For Each P In .Columns(1).SpecialCells(xlCellTypeBlanks).Areas
P = P(0)
Next P
.Columns(2).Replace "Nom ", ""
End With
[B1:C1] = Array("Question", "Réponse")
end subAuteur : Laurent Longre
Mots clefs associés à cette page : calcul, calculer, tableau, tableau croisé dynamique, tcd
- Vous devez vous identifier ou créer un compte pour écrire des commentaires
