Salut à tous,
Petite modif dans le code joint par Michel et Celeda dans le fichier pour la numérotation des doublons. Car application.transpose a une limite à 5000 et quelques lignes. Voici le code à mettre derrière l'userform:
Option Explicit
'adapté pour XL97, V2 application.transopose remplacé
Option Base 1
Const Titre = "Faites votre choix"
Const Lab = "Cliquez sur la colonne où se situent les noms des équipements"
Dim Tablo, Tablo2(), Tablo3()
Private Sub CommandButton1_Click()
With ListBox1
Select Case .ListIndex
Case -1: Exit Sub
Case 0: Insertion (2): Princ "C", 3
Case 1: Insertion (1): Princ "C", 3
Case Else: Princ Right(.List(.ListIndex), 1), .ListIndex + 1
End Select
Unload Me
End With
End Sub
Private Sub UserForm_Initialize()
Me.Caption = Titre
With Label1
.Caption = Lab
.AutoSize = True
End With
With ListBox1
.List = Array("Colonne A", "Colonne B", "Colonne C", _
"Colonne D", "Colonne E", "Colonne F")
End With
End Sub
Sub Princ(K As String, T As Byte)
Dim L1&, L2&, C&, Plage As Range
On Error Resume Next
Application.ScreenUpdating = False
L1 = Range(K & "1").End(xlDown).Row + 1
L2 = Range(K & 65536).End(xlUp).Row
C = Range("IV" & L1).End(xlToLeft).Column
Set Plage = Range(Range("A" & L1), Cells(L2, C))
Plage.Columns("A:B").ClearContents
Tri Plage, T
Tablo = TransposeGrandTab(Plage.Columns(T).Value)
Doublons
Plage.Columns(1) = TransposeGrandTab(Tablo2)
Plage.Columns(2) = TransposeGrandTab(Tablo3)
On Error GoTo 0
End Sub
Private Function Tri(Plage As Range, C As Byte)
With Plage
.Sort .Cells(C), xlAscending, , , , , , xlNo
End With
End Function
Private Sub Doublons()
Dim I&, J&, K&, L&, Item
ReDim Tablo2(UBound(Tablo, 2)): ReDim Tablo3(UBound(Tablo, 2))
J = 1: L = 1: K = 1
For I = LBound(Tablo, 2) To UBound(Tablo, 2)
If Item = Tablo(1, I) Then
J = J + 1: Tablo3(K) = J: K = K + 1
Else
Item = Tablo(1, I): J = 1
Tablo2(K) = L: Tablo3(K) = J
L = L + 1: K = K + 1
End If
Next I
End Sub
Private Function Insertion(Nb As Byte)
Dim I As Byte
For I = 1 To Nb
Columns(1).Insert
Next I
End Function
Function TransposeGrandTab(T) 'Zon
'Application.transpose est limité à 5000 et qques jusqu'à XL2002
Dim Temp, I&, J&, Z As Byte, Nb As Byte
On Error Resume Next
Do
Nb = Nb + 1
Z = UBound(T, Nb + 1)
Loop Until Err
If Nb = 1 Then
ReDim Temp(UBound(T), 1 To 1)
For I = LBound(T) To UBound(T)
Temp(I, 1) = T(I)
Next I
Else
ReDim Temp(UBound(T, 2), UBound(T, 1))
For I = LBound(T, 2) To UBound(T, 2)
For J = LBound(T, 1) To UBound(T, 1)
Temp(I, J) = T(J, I)
Next J
Next I
End If
TransposeGrandTab = Temp
End Function
A+++