TCD sans calcul

Je cherche à faire un TCD mais sans calcul ! j'ai un grand tableau avec des noms en colonne A, des questions en colonne B et les réponses en colonne C. Je voudrais voir apparaître les réponses aux intersections entre les lignes et les colonnes.

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 sub
Private 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 Do While B2 B2 = B2 + 1
Loop
Do While H2 > B1 And Arr(Idx(H2), 1) > Elt
H2 = H2 - 1
Loop
If B2 IdxTemp = Idx(B2)
Idx(B2) = Idx(H2)
Idx(H2) = IdxTemp
End If
If B2 B2 = B2 + 1
H2 = H2 - 1
End If
Loop
If H2 > B1 Then Recurse B1, H2
If B2 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 sub
Auteur(s) : 

Ce mois-ci sur Excelabo

- Pas de nouvelle page.
- 2 pages modifiées.