Microsoft 365 VBA Transpose

[Regueiro]

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

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]

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

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]

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 :

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

 

[Regueiro]

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.

 

[Regueiro]

Sylvanu
J'ai essayer votre code.
Par contre il transpose les 5 lignes dans 5 colonnes
Je souhaitais sur une seule colonne
Merci

 

[sylvanu]

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 :

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 )

 

[sylvanu]

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 :

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

 

[Regueiro]

Bonsoir à Tous - Sylvanu
Merci beaucoup très rapide
encore une requête
C'estt possible de transposer avec liaison ?

 

[sylvanu]

Bonsoir,
Pas avec cette méthode car un array construit de la sorte ne comporte que des valeurs.
D'ailleurs je pense que par dico, c'est la même chose.
Peut être la possibilité de rafraichir les données lors du besoin.

 

[Regueiro]

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

=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]

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]

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:

N'est à exécuter qu'une seule fois puisque dynamique. Avec :

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