Tableau un peu spéciale ....
Alex
Exemple :
Avant :
[Nom ][Nom_Machine ][ IP ]
[Alex][Machine_Alex][1.1.1.1]
[TITI][Machine_TITI][1.1.1.2]
[TOTO][Machine_TOTO][1.1.3.1]
Apres :
[Machine_Alex][Machine_TITI][Machine_TOTO]
[Alex][1.1.1.1 ][ ][ ]
[TITI][ ][1.1.1.2 ][ ]
[TOTO][ ][ ][1.1.3.1 ]
Voila !
C'est simple mais impossible de ne pas faire de calcul avec le TCD !
J'utilise EXCEL 97 !
Merci
Laurent Longre
Tu peux essayer cette macro (lancer la procédure ListeVersTableau). Elle
va un peu plus loin que ce que tu demandes, mais elle devrait te
convenir. Elle marche très bien sur ton exemple.
Cette procédure construit sur une nouvelle feuille un tableau à partir
de la plage sélectionnée (3 colonnes). Le 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)
Cordialement,
Laurent
'==========================================================
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
'==========================================================
Alex a écrit :
Alex
Merci pour votre aide.
Joyeuse fete.
Alex.R