XL 2019 URGENT COVID 19 - Macro Transpose

[Ternoise]

Bonjour à tous
Afin de contacter mes patients rapidement, j'ai besoin d'une macro pouvant faire ceci :
Transposer toutes les 4 lignes dans 4 colonnes différentes

A1 : Nom
A2 : Adresse
A3 : VILLE
A4 : Tel
A5 : Nom
A6 : Adresse
A7 : VILLE
A8 : Tel

etc jusqu'a 11 000 lignes

Transposer dans une nouvelle feuille

Colonne A : les noms
Colonne B : les adresses
Colonne C : les villes
Colonne D : les Tel

Merci de votre aide
David

 

[Staple1600]

Bonjour le fil, Ternoise

Ce qui est urgent, c'est que tu relises la charte du forum, camarade!
😉

2 – Tous les membres du forum répondent gracieusement aux questions. Il n’y a donc aucune obligation de résultat et de délai. Les mots URGENT, SOS, AU SECOURS sont donc à bannir.

 

[job75]

Bonjour Ternoise, JM,

Si c'est pour la Covid 19 allons vite.

En A2 de la 2ème feuille, à tirer à droite et vers le bas :

=INDEX(Liste!$A:$A;COLONNE()+4*(LIGNE()-2))

A+

 

[Ternoise]

Merci beaucoup Job75
C'est nickel.

 

[mapomme]

Bonjour à tous,

Ou par macro depuis la feuille Feuil1 vers la feuille Feuil2, Cliquez sur le bouton Hop!

edit: bonjour 🙂 à @job75, @Staple1600, @GALOUGALOU

 

[Staple1600]

Re, Bonjour Job75

COVID-19 ou pas, Excel ne sera pas d'un grand renfort.
Le message#1 parlait d'une macro
En voici une "bricolée" non dans l'urgence mais dans le désœuvrement (pour cause de confinement)

Sub Transpose()
Dim c As Range, rng As Range
Set rng = [A1].CurrentRegion.Columns(1)
For Each c In rng.Cells
If c.Row Mod 4 = 1 Then
Feuil2.Cells(Rows.Count, 1).End(3)(2).Resize(, 4) = Application.Transpose(c.Resize(4).Value)
End If
Next
End Sub

PS: je sais que c'est plus rapide avec un Array, mais je laisse cela aux urgentistes d'XLD.
😉

EDITION: Bonjour mapomme (je ne t'avais pas vu passé)

 

[Ternoise]

Merci à tous.

 

[GALOUGALOU]

Bonjour le forum bonjour le fil
allez très rustique mais une solution de plus par macro
cordialement
galougalou

 

[Staple1600]

Re

Une autre pour la route 😉

Sub Transpose_bis()
Dim i&, j&, f As Worksheet: Set f = Sheets("Feuil2")
With Application
  .ScreenUpdating = False
    For i = 1 To Cells(Rows.Count, 1).End(3).Row - 3 Step 4
    j = j + 1: f.Cells(j, 1).Resize(, 4) = .Transpose(Range("A" & i).Resize(4))
    Next i
End With
f.Columns("A:D").AutoFit
End Sub

PS: Normalement , Ternoise n'en a plus besoin.
Il doit être au tél pour contacter ces 2750 patients
😉


EDITION: Bonjour jmfmarques

 

[job75]

Bonjour mapomme, GALOUGALOU,

Ma formule du post #3 est tellement simple qu'il faut l'utiliser même en VBA :

Private Sub Worksheet_Activate()
With [A2].Resize(Application.Ceiling(Application.CountA(Sheets("Liste").Columns(1)), 4) / 4, 4)
    .Formula = "=INDEX(Liste!$A:$A,COLUMN()+4*(ROW()-2))"
    .Value = .Value 'supprime les formules
End With
End Sub

Elle se déclenche quand on active la 2ème feuille du fichier joint.

A+

 

[jmfmarques]

Bonjour à tous
C'est vrai, que le confinement conduit à l'ennui et qu'on ne sait plus quoi inventer, y compris ce qu'il y a de plus fou.
Allez -->> une méthode que je ne conseillerais pas (même à mon ennemi le konard_virus), mais qui a le mérite d'amuser --->>

Set toto = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Set titi = Range("A1:D" & toto.Count / 4)
For k = 1 To toto.Count
  titi(k) = toto(k)
  If k > 1 Then toto(k) = ""
Next

 

[mapomme]

Bonjour @jmfmarques,

Attention! Si jamais le nombre de lignes n'est pas un multiple de 4 alors ça coince.
je ferai plutôt: Set titi = Range("A1 : D" & 1 + toto.Count \ 4)

 

[jmfmarques]

Bonjour mapomme
Tu as raison (je n'avais pas prévu des données in complètes).
Mais dans ce cas : inversons donc le signe / --->> \ pour définir titi :

Set titi = Range("A1:D" & toto.Count \ 4)

 

[mapomme]

Re @jmfmarques,

Alors ce qui suit semble le faire aussi:

Set titi = Range("A1:D4")

 

[chris]

Bonjour à tous

Une solution PowerQuery intégré à Excel 2019

Mise à jour par Données, Actualiser tout