Microsoft 365 Créer une liste sans cellules vides à partir d'un fichier

Private Sub Worksheet_Activate()
Dim F1 As Worksheet, base1, nlig1, ncol1, F2 As Worksheet, base2, t, i&, j&, n&, max
   Set F1 = Worksheets("Feuil1"): base1 = "A1": nlig1 = 395: ncol1 = 92
   Set F2 = Worksheets("Feuil2"): base2 = "B3"
   t = F1.Range(base1).Resize(nlig1, ncol1)
   For j = 1 To UBound(t, 2)
      n = 0
      For i = 1 To UBound(t)
         If t(i, j) <> "" Then n = n + 1: t(n, j) = t(i, j)
      Next i
      For i = n + 1 To UBound(t): t(i, j) = "": Next
      If n > max Then max = n
   Next j
   Application.ScreenUpdating = False
   F2.Range(base2).Resize(nlig1, ncol1).Clear
   F2.Range(base2).Resize(UBound(t), UBound(t, 2)) = t
   F1.Range(base1).Resize(max, ncol1).Copy
   F2.Range(base2).PasteSpecial xlPasteFormats
   Application.Goto F2.Range("a1"), True
   Application.CutCopyMode = False
End Sub

=SIERREUR(PETITE.VALEUR(SI(ESTNUM(D$14:D$44);D$14:D$44);LIGNE(P1));"")

Sub Grouper()
Dim nlig&, ncol%, tablo, resu(), j%, n&, i&
With Range("D13:L" & Cells.SpecialCells(xlCellTypeLastCell).Row)
    nlig = .Rows.Count
    ncol = .Columns.Count
    tablo = .Value 'matrice, plus rapide
    ReDim resu(1 To nlig, 1 To ncol)
    For j = 1 To ncol
        n = 0
        For i = 1 To nlig
            If tablo(i, j) <> "" Then
                n = n + 1
                resu(n, j) = tablo(i, j)
            End If
    Next i, j
    .Offset(, 12) = resu
End With
End Sub