Autres Transposition

[Guyrold]

Bonjour à tous
Svp je souhaite faire une transposition dynamique d'une colonne en ligne sans les cellules vides de la colonne.
Je veux que les données de la colonne soit recopiées chronologiquement de façon dynamique dans une ligne sans les cellules vides de la colonne. Merci.

 

[M12]

Bonjour,
Quelle colonne sur quelle ligne
Un fichier exemple sans données confidentielles serait souhaitable

 

[Guyrold]

Bonjour,
Quelle colonne sur quelle ligne
Un fichier exemple sans données confidentielles serait souhaitable

En fait Mon fichier est très volumineux, je l'ai réduit pour mieux vous expliquer.
Les données de la colonne à transposer se situent entre la cellule B5 et B10100.
Ces données doivent être copier de façon dynamique sur la 3ème ligne à partir de la cellule E3 de sorte que les cellules vides de la colonne B ne soient pas recopiées et que les modifications des valeurs de la colonne B agissent également sur les valeurs recopiées à la 3ème ligne.
CI joint un exemple de fichier réduit.
Cordialement.

 

[Guyrold]

En fait Mon fichier est très volumineux, je l'ai réduit pour mieux vous expliquer.
Les données de la colonne à transposer se situent entre la cellule B5 et B10100.
Ces données doivent être copier de façon dynamique sur la 3ème ligne à partir de la cellule E3 de sorte que les cellules vides de la colonne B ne soient pas recopiées et que les modifications des valeurs de la colonne B agissent également sur les valeurs recopiées à la 3ème ligne.
CI joint un exemple de fichier réduit.
Cordialement.

J'ai oublié de souligner que les données de la colonne à transposer ne sont pas figées. Ce sont des valeurs de stock qui sont renseigné en fonction du temps lorsqu'il y a un mouvement sur le stock

 

[M12]

Re,
A tester

 

[mapomme]

Bonsoir à tous,

Si vous disposez de Office 365, une seule formule en E3 suffit:
=TRANSPOSE(FILTRE(B5:B9999;B5:B9999<>""))

 

[job75]

Bonjour Guyrold, M12, mapomme, le forum,

Voici une solution très rapide :

Private Sub Worksheet_Change(ByVal Target As Range)
With [B5:B10100]
    If Intersect(Target, .Cells) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next 'si aucune SpecialCell
    [E3].Resize(, Columns.Count - 2).ClearContents 'RAZ
    .SpecialCells(xlCellTypeConstants).Copy 'copie les constantes
End With
[E3].PasteSpecial xlPasteValues, Transpose:=True 'collage spécial valeurs avec transposition
Target.Select
Application.CutCopyMode = 0
End Sub

Avec la plage B5:B10100 renseignée la macro s'exécute chez moi en 0,08 seconde.

PS : s'il y a des formules dans la plage leurs valeurs ne sont pas copiées.

A+

 

[job75]

S'il y a des formules dans B5:B10100 il suffit de les mémoriser, fichier (2) :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim memf
With [B5:B10100]
    If Intersect(Target, .Cells) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False 'désactive les évènements
    On Error Resume Next 'si aucune SpecialCell
    [E3].Resize(, Columns.Count - 2).ClearContents 'RAZ
    memf = .Formula 'mémorise les formules et les autres contenus
    .Value = .Value 'supprime les formules
    .SpecialCells(xlCellTypeConstants).Copy 'copie les constantes
    [E3].PasteSpecial xlPasteValues, Transpose:=True 'collage spécial valeurs avec transposition
    .Formula = memf 'restitue les formules
    Application.EnableEvents = True 'réactive les évènements
End With
Target.Select
Application.CutCopyMode = 0
End Sub

La durée d'exécution est très peu augmentée => 0,09 seconde.

 

[mapomme]

Re,

Cliquez sur le bouton Hop!
Le code (dans module) est très rapide aussi :

Sub Transposer()
Dim der, t, i&, n&, deb
   deb = Timer    'juste pour les tests
   With ActiveSheet
      t = .Columns("b:b").Resize(.UsedRange.Row + .UsedRange.Rows.Count-1)
      ReDim r(1 To 1, 1 To UBound(t))
      For i = 5 To UBound(t)
         If t(i, 1) <> "" Then n = n + 1: r(1, n) = t(i, 1)
      Next i
      If n > Columns.Count - Range("e3").Column + 1 Then MsgBox "Echec: trop de cellules à transposer !": Exit Sub
      If n = 0 Then MsgBox "Echec: aucune cellule à transposer !": Exit Sub
      .Range(.Range("e3"), Cells(3, Columns.Count)).Clear
      .Range("e3").Resize(, n) = r
   End With
   MsgBox Format(n, "#,##0") & " cellules transposée en " & Format(Timer - deb, "0.00\ sec.")    'juste pour les tests
End Sub

 

[job75]

Bonsoir mapomme,

Oui, avec des tableaux VBA c'est le plus rapide, cette macro s'exécute chez moi en moins de 0,01 seconde :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo, resu(), i%, n%
With [B5:B10100]
    If Intersect(Target, .Cells) Is Nothing Then Exit Sub
    tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
End With
ReDim resu(1 To 1, 1 To UBound(tablo))
For i = 1 To UBound(tablo)
    If tablo(i, 1) <> "" Then n = n + 1: resu(1, n) = tablo(i, 1)
Next
'---restitution---
With [E3] '1ère cellule de destination, à adapter
    If n Then .Resize(, n) = resu
    .Offset(, n).Resize(, Columns.Count - n - .Column + 1).ClearContents 'RAZ à droite
End With
End Sub

Bonne nuit.