Autres Transposition

Guyrold

XLDnaute Nouveau
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.
 

Guyrold

XLDnaute Nouveau
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.
 

Pièces jointes

  • Transposer dynamiquement colonne.xlsx
    8.6 KB · Affichages: 9

Guyrold

XLDnaute Nouveau
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
 

job75

XLDnaute Barbatruc
Bonjour Guyrold, M12, mapomme, le forum,

Voici une solution très rapide :
VB:
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+
 

Pièces jointes

  • Transposer dynamiquement colonne(1).xlsm
    49.3 KB · Affichages: 2

job75

XLDnaute Barbatruc
S'il y a des formules dans B5:B10100 il suffit de les mémoriser, fichier (2) :
VB:
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.
 

Pièces jointes

  • Transposer dynamiquement colonne(2).xlsm
    50.2 KB · Affichages: 2

mapomme

XLDnaute Barbatruc
Supporter XLD
Re,

Cliquez sur le bouton Hop!
Le code (dans module) est très rapide aussi :
VB:
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
 

Pièces jointes

  • Guyrold- Transposer- v1.xlsm
    195.3 KB · Affichages: 6
Dernière édition:

job75

XLDnaute Barbatruc
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 :
VB:
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.
 

Pièces jointes

  • Transposer dynamiquement colonne(3).xlsm
    50.8 KB · Affichages: 6

Discussions similaires

Réponses
8
Affichages
467

Statistiques des forums

Discussions
312 922
Messages
2 093 658
Membres
105 778
dernier inscrit
Ricky22