Option Explicit
Const ColonneSortie = "n"
Sub Test()
Dim i&, j&, n&, nInd&, k&, xrgX As Variant, X, som, Debut, wks As Worksheet
' Lecture de la plage des données
Set wks = ActiveSheet
On Error Resume Next
Set xrgX = Application.InputBox(prompt:="Sélectionner la plage des données, svp...", Type:=8)
If xrgX Is Nothing Then
MsgBox "Erreur dans la saisie de la plage", vbInformation
Exit Sub
End If
wks.Select
Debut = Timer
On Error GoTo 0
X = xrgX.Value 'tableau des valeurs à traiter
' On normalise X (ie on remonte les valeurs de chaque colonne
' pour supprimer les valeurs 'vides'). Le tableau résultat est T
' Parallèlement, on construit les vecteurs contenant les futurs
' indices des colonnes et le nombre de valeur de chaque colonne de T
ReDim T(1 To UBound(X), 1 To UBound(X, 2)) ' T sera X mais normalisé
ReDim ind(1 To UBound(X, 2)) 'vecteur des indices de colonnes
ReDim max(1 To UBound(X, 2)) 'vecteur des nombres de valeurs de chaque colonne
Dim maxligne# 'nombre de lignes du résultat
maxligne = 1
For j = 1 To UBound(X, 2)
n = 0
For i = 1 To UBound(X)
If X(i, j) <> "" Then n = n + 1: T(n, j) = X(i, j)
Next i
If n = 0 Then
MsgBox "La colonne " & j & " de la plage est vide. Arrêt du traitement.", vbInformation: Exit Sub
Else
max(j) = n: ind(j) = 0 ' avec initialisation de Ind
maxligne = maxligne * n 'calcul du nombre de ligne du résultat
End If
Next j
If maxligne > Rows.Count Then
' le nombre de ligne du résultat est supérieur au nombre de ligne de la feuille
MsgBox "Le nbre de résultat est trop grand. Echec.", vbCritical
Exit Sub
End If
ReDim res(1 To 250000, 1 To UBound(T, 2) + 1) ' Tableau des résultats
Dim nres& ' curseur de ligne du tableau résultat
ReDim v(1 To UBound(T, 2)) ' vecteur 'générique' intermédiaire d'une ligne
' v ne contient pas les valeurs de T
' mais pour élément un entier de 1 au nombre max de valeur
' de la colonne
Range(Cells(1, ColonneSortie), Cells(1, Columns.Count)).EntireColumn.Clear
Application.ScreenUpdating = False: DoEvents
nInd = 1 'on ommence par travailler la colonne 1 de la plage
Do
'incrémentation de l'indice de la colonne nInd
ind(nInd) = ind(nInd) + 1
If ind(nInd) > max(nInd) Then
'si l'indice dépasse le nombre de valeurs de la colonne nInd
'alors on repasse tous les indices des colonnes >= nInd à zéro
For k = nInd To UBound(T, 2): ind(k) = 0: Next
'et on repart traiter le colonne nInd-1
nInd = nInd - 1
Else
'l'indice de la colonne nInd est dans la limite du nombre max de valeurs de la colonne nInd
v(nInd) = ind(nInd) 'On stocke l'indice nInd dans le vecteur résultat de la ligne
' à la colonne nInd
If nInd = UBound(T, 2) Then
' si on a traité la dernière colonne de la plage
' on va stocker le résultat de la ligne dans le tableau résultat res()
nres = nres + 1: som = 0 'incrémentation de la ligne et RAZ de la somme de la ligne
' on va stocker les valeurs dans la ligne nres du tableau res()
' l'instruction suivante ne sert que pour avoir un résultat générique.
' activer l'instruction suivante si c'est ce que vous désirez
' For k = 1 To UBound(v): res(nres, k) = v(k): Next: res(nres, UBound(res, 2)) = "" 'générique
' l'instruction suivante ne sert que pour avoir un résultat avec les valeurs de T
' la désactiver si vous désirez un résultat générique (indépendant des valeurs sources)
For k = 1 To UBound(v): res(nres, k) = T(v(k), k): som = som + T(v(k), k): Next
res(nres, UBound(res, 2)) = som 'stockage de la somme de la ligne
If nres = UBound(res) Then
'si on a complété la dernière ligne de res(), alors on l'affiche sur la feuille
k = Cells(Rows.Count, ColonneSortie).End(xlUp).Row
If k > 1 Then k = k + 1
Cells(k, ColonneSortie).Resize(nres, UBound(res, 2)) = res
nres = 0 'raz de l'index de ligne de l'écriture dans res()
End If
Else
' on n'a pas encore atteint la dernière colonne de la ligne
' on incrémente nInd pour traiter la colonne suivante
nInd = nInd + 1
End If
End If
' condition de sortie de la boucle
If nInd = 0 Then Exit Do
Loop
' on teste si on a écrit des lignes dans res() depuis la dernière fois,
' si oui, on l'affiche sur la feuille
If nres > 0 Then
k = Cells(Rows.Count, ColonneSortie).End(xlUp).Row
If k > 1 Then k = k + 1
Cells(k, ColonneSortie).Resize(nres, UBound(res, 2)) = res
End If
' Quelques mises en forme
Cells(1, ColonneSortie).Offset(, UBound(T, 2)).Resize(maxligne).Font.Color = RGB(0, 0, 255)
Cells(1, ColonneSortie).Resize(maxligne, UBound(res, 2)).NumberFormat = "0.00"
MsgBox Format(maxligne, "#,##0\ Lignes pour une durée de ") & Format(Timer - Debut, "0.0\ sec."), vbInformation
End Sub