Microsoft 365 VBA Transpose

Regueiro

XLDnaute Impliqué
Bonjour à tous
Comment transposer les données en I4
Merci pour votre Aide

VB:
Sub transpose()
Dim WS1 As Worksheet
Set WS1 = Sheets("data for diagrams")
'Range("C32:CY32,C47:CY47,C63:CY63;C79:CY79,C95:CY95")
    Dim a(1 To 5)
        a(1) = WS1.Range("C32:CY32").Value
        a(2) = WS1.Range("C47:CY47").Value
        a(3) = WS1.Range("C63:CY63").Value
        a(4) = WS1.Range("C79:CY79").Value
        a(5) = WS1.Range("C95:CY95").Value
 
  For i = 1 To 5
    For j = 1 To UBound(a(i))
      'If a(i)(j, 1) <> "" Then ComboBox1.AddItem a(i)(j, 1)
      'If a(i)(j, 1) <> "" Then
        [I4].Resize (a(i)(j, 1) = Application.transpose(a(i)(j, 1)))
          
    Next j
  Next i
End Sub
 

Regueiro

XLDnaute Impliqué
Bonjour à tous
Comment transposer les données en I4
Merci pour votre Aide

VB:
Sub transpose()
Dim WS1 As Worksheet
Set WS1 = Sheets("data for diagrams")
'Range("C32:CY32,C47:CY47,C63:CY63;C79:CY79,C95:CY95")
    Dim a(1 To 5)
        a(1) = WS1.Range("C32:CY32").Value
        a(2) = WS1.Range("C47:CY47").Value
        a(3) = WS1.Range("C63:CY63").Value
        a(4) = WS1.Range("C79:CY79").Value
        a(5) = WS1.Range("C95:CY95").Value
 
  For i = 1 To 5
    For j = 1 To UBound(a(i))
      'If a(i)(j, 1) <> "" Then ComboBox1.AddItem a(i)(j, 1)
      'If a(i)(j, 1) <> "" Then
        [I4].Resize (a(i)(j, 1) = Application.transpose(a(i)(j, 1)))
         
    Next j
  Next i
End Sub
Sub essai3()
Dim WS1 As Worksheet
Set WS1 = Sheets("data for diagrams")
a = WS1.Range("C32:CY32")
b = WS1.Range("C47:CY47")
d = WS1.Range("C63:CY63")
e = WS1.Range("C79:CY79")
f = WS1.Range("C95:CY95")
c = Fusion(a, b, d, e, f)
[I5].Value = 0
[I6].Resize(UBound(c)) = c
End Sub
Function Fusion(tab1, tab2, tab3, tab4, Optional tab5)
Dim temp()
Set mondico1 = CreateObject("Scripting.Dictionary")
For Each c In tab1
If c <> "" And c <> 0 Then tmp = c: mondico1(tmp) = ""
Next c

For Each c In tab2
If c <> "" And c <> 0 Then tmp = c: mondico1(tmp) = ""
Next c

For Each c In tab3
If c <> "" And c <> 0 Then tmp = c: mondico1(tmp) = ""
Next c

For Each c In tab4
If c <> "" And c <> 0 Then tmp = c: mondico1(tmp) = ""
Next c

If Not IsMissing(tab5) Then
For Each c In tab5
If c <> "" And c <> 0 Then tmp = c: mondico1(tmp) = ""
Next c
End If
On Error Resume Next
tmp = Application.Caller.Rows.Count
If Err = 0 Then ReDim temp(1 To Application.Caller.Rows.Count) Else ReDim temp(1 To mondico1.Count)
On Error GoTo 0
i = 1
For Each c In mondico1.keys
temp(i) = c
i = i + 1
Next
Fusion = Application.transpose(temp)
End Function
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Regueiro,
Un petit fichier test aurait été le bienvenu.
En PJ une approche avec un transpose par collage, ce qui n'est guère plus long pour 5 plages, avec :
VB:
Sub Copier()
Dim WS1, L, i%
Application.ScreenUpdating = False
Set WS1 = Sheets("data for diagrams")
L = Array(32, 47, 63, 79, 95)
For i = 0 To UBound(L)
    WS1.Range("C" & L(i) & ":CY" & L(i)).Copy
    Cells(4, 9 + i).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Next i
Application.CutCopyMode = False
[A1].Select
End Sub
 

Pièces jointes

  • EssaiTranspose.xlsm
    17.2 KB · Affichages: 0

Regueiro

XLDnaute Impliqué
Merci pour votre réponse
Je ne pouvais pas mettre de fichier pour l'instant
Fichier très lourd pour du dimensionement de poutre Métallique
avec plusieurs cas de charges.

Capture d'écran 2024-03-12 170850.png
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Je ne pouvais pas mettre de fichier pour l'instant
Fichier très lourd pour du dimensionement de poutre Métallique
Un fichier test est un fichier minimal pour poser le problème, à l'instar de ma PJ.
Je souhaitais sur une seule colonne
Oups ! Pas bien compris la demande.
En PJ la même approche, il suffit de remplacer la ligne de collage avec :
VB:
Cells(4 + 101 * i, "I").PasteSpecial Paste:=xlPasteValues, Transpose:=True

Les futurs lecteurs auront ainsi deux approches.
( à noter que ( sur mon PC Win10 XL2007 ) la solution par dico prend 32ms, celle par collage 60ms donc plus lente )
 

Pièces jointes

  • EssaiTranspose V2.xlsm
    20.7 KB · Affichages: 0

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
"Just for the fun" un essai en PJ donnant le même temps qu'avec un dico, mais sans dico ... et une macro plus courte :
VB:
Sub Copier()
Dim WS1, L, i%
Application.ScreenUpdating = False
Set WS1 = Sheets("data for diagrams")
L = Array(32, 47, 63, 79, 95)
For i = 0 To UBound(L)
    T = WS1.Range("C" & L(i) & ":CY" & L(i))
    Range("I" & 4 + 101 * i & ":I" & 104 + 101 * i) = Application.Transpose(T)
Next i
End Sub
 

Pièces jointes

  • EssaiTranspose V3.xlsm
    20.8 KB · Affichages: 1
Dernière édition:

Regueiro

XLDnaute Impliqué
Merci pour ta réponse
j'ai utilisé la méthode de Boisgontier
Un peu plus fastidieux mais cela fonctionne

VB:
=fusion(TABX1;TABX2;TABX3;TABX4;TABX5)

Function Fusion(tab1, tab2, tab3, tab4, Optional tab5)
 Dim temp()
 Set mondico1 = CreateObject("Scripting.Dictionary")
 For Each c In tab1
 'If c <> "" And c <> 0 Then tmp = c: mondico1(tmp) = ""
   If c <> "" Then tmp = c: mondico1(tmp) = ""
 Next c
 
 For Each c In tab2
   If c <> "" Then tmp = c: mondico1(tmp) = ""
 Next c
 
 For Each c In tab3
   If c <> "" Then tmp = c: mondico1(tmp) = ""
 Next c
 
 For Each c In tab4
   If c <> "" Then tmp = c: mondico1(tmp) = ""
 Next c
 
 If Not IsMissing(tab5) Then
    For Each c In tab5
     If c <> "" Then tmp = c: mondico1(tmp) = ""
    Next c
 End If
 On Error Resume Next
 tmp = Application.Caller.Rows.Count
 If Err = 0 Then ReDim temp(1 To Application.Caller.Rows.Count) Else ReDim temp(1 To mondico1.Count)
 On Error GoTo 0
 i = 1
 For Each c In mondico1.keys
    temp(i) = c
    i = i + 1
 Next
 Fusion = Application.transpose(temp)
End Function
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
Qu'entendiez vous par "transposer avec liaison " ?
Car votre macro transfère des valeurs, il n'y a pas de liaisons.
Par contre il supprime les valeurs vides.

Pour moi "transposer avec liaison" permet au nouveau tableau de suivre de façon dynamique les évolutions dans les 5 plages.
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
"Just for the fun", en PJ un copier coller avec liaison.
C'est à dire que la zone coller est dynamique et toujours l'image des plages copiées, comme le ferait à la main un copier coller avec liaisons:
1710315641397.png

N'est à exécuter qu'une seule fois puisque dynamique. Avec :
VB:
Sub CopierAvecLiaisons()
Dim WS1, L, i%, Formule$
Application.ScreenUpdating = False
Set WS1 = Sheets("data for diagrams")
L = Array(32, 47, 63, 79, 95)
For i = 0 To UBound(L)
' Définition de la plage où coller les formules
    Plage = WS1.Range("$C" & L(i) & ":$CY" & L(i))
    ' Formule equivalant à : =INDEX('data for diagrams'!$C$32:$CY$32;1;LIGNE()-3) pour la 1ere valeur.
    Formule = "=INDEX('data for diagrams'!$C$" & L(i) & ":$CY$" & L(i) & ",1,ROW()-" & 101 * i + 3 & ")"
    ' Collage des formules
    Range("I" & 4 + 101 * i & ":I" & 104 + 101 * i).Formula = Formule
Next i
End Sub
 

Pièces jointes

  • EssaiTranspose V4.xlsm
    23.8 KB · Affichages: 1

Statistiques des forums

Discussions
312 826
Messages
2 092 513
Membres
105 439
dernier inscrit
Nassir