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 < 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 sub

Auteur :

Mots clefs associés à cette page : , , , ,