Salut,
Si la mêthode reste la même, je passe uniquement par des tableaux VBA, comme cela on écrit qu'une fois dans la feuille de calcul(ce qui est le plus long d'ailleurs).
Même si le code est plus long en nombre de lignes que didier il est par contre beaucoup plus rapide à l'éxécution.
J'ai mis une constante pour le nombre de colonnes, ici 7 mais on peut travailler de 2 j'usqu'à 256 colonnes. tu peut reprendre l'inputbox de didier si tu ne veux pas travailler toujours sur 7 colonnes.
Option Explicit
Const Nbcol As Byte = 7
Const Sep$ = "~" 'suivant les données adapter le caractère d'espacement.
Sub Princ()
Dim Plage As Range, T
Set Plage = Range([A2], [I65536].End(xlUp)) 'à adapter
T = Concatener(Plage.Value)
T = Doublons(T, 1)
If IsArray(T) Then
T = DeconcaTener(T, UBound(Plage.Value, 2))
T = InverseTab(T, 1)
With Plage
.Clear 'supprimer le commentaire aprés les tests
.Cells(1, 1).Resize(UBound(T), UBound(T, 2)) = T
End With
Else: MsgBox T
End If
End Sub
Function Concatener(T)
Dim I&, J&, Temp
ReDim Temp(1 To UBound(T), 1 To 1 + (UBound(T, 2) - Nbcol))
For I = LBound(T) To UBound(T)
For J = 1 To Nbcol
Temp(I, 1) = Temp(I, 1) & Sep & T(I, J)
Next J
For J = Nbcol + 1 To UBound(T, 2)
Temp(I, J - 1) = T(I, J)
Next J
Next I
Concatener = Temp
End Function
Function Doublons(T, ColT As Byte) 'Zon
Dim I&, J&, K&, Tablo As New Collection
Dim Temp()
For I = LBound(T, 1) To UBound(T, 1)
On Error Resume Next
Tablo.Add T(I, ColT), CStr(T(I, ColT))
If Err = 0 Then
ReDim Preserve Temp(1 To UBound(T, 2), 1 To J + 1)
For K = 1 To UBound(Temp)
Temp(K, J + 1) = T(I, K)
Next K
J = J + 1
End If
Next I
Doublons = IIf(J > 0, Temp, "Pas de doublons")
End Function
Function DeconcaTener(T, N As Byte)
Dim I&, J&, K&, Temp(), Tablo
K = 1
For I = LBound(T, 2) To UBound(T, 2)
Tablo = Split(T(1, I), Sep)
ReDim Preserve Temp(1 To N, 1 To K)
For J = LBound(Tablo) + 1 To UBound(Tablo)
Temp(J, K) = Tablo(J)
Next J
For J = Nbcol + 1 To N
Temp(J, K) = T(J - 1, I)
Next J
K = K + 1
Next I
DeconcaTener = Temp
End Function
Function InverseTab(T, Optional Base As Byte = 0)'Zon
Dim Temp(), I&, J&
ReDim Temp(Base To UBound(T, 2), Base To UBound(T))
For I = LBound(T, 2) To UBound(T, 2)
For J = LBound(T) To UBound(T)
Temp(I, J) = T(J, I)
Next J
Next I
InverseTab = Temp
End Function
=>>>Si tu as Xl97 remplaces split par splitzon97
Function SplitZon97(ByVal Ch$, Sep$)
Dim Pos&, PosS&, T(), I&
Pos = 1
Do
PosS = InStr(Pos, Ch, Sep)
ReDim Preserve T(I)
On Error Resume Next
T(I) = Mid(Ch, Pos, PosS - Pos)
If Err <> 0 Then
Pos = Pos - 1
T(I) = Right(Ch, Len(Ch) - Pos)
Exit Do
End If
Pos = PosS + 1
I = I + 1
Loop While PosS > 0
SplitZon97 = T
End Function
A+++