Transpose en incrémentant " Range "

Bonsoir,

J'ai plusieurs fichiers Excel qui sont tous structurés de la méthode suivante :

Nom de l'entreprise A4
Ville (Province) Code Postal A5
Pays A6

Site Internet A8
Information complémentaireA9
Afficher la localisation sur la carteA10


Je copie et transpose seulement les cellules A4:A6 de la feuille 1 vers les cellules A1:C1 de la feuille 2. Je répete la même étape pour chaque entreprise qui se trouve dans la feuille 1. Étant donnée que mes fichiers sont tous structurés de la même méthode:D, ma deuxième entreprise se trouve sur la ligne A12:A14, la troisième A20:A22 et etc... Donc j'ai toujours un gap de 8 entre mes entreprises.

Parfois les fichier contiennent 500 lignes d'autre fois seulement 40 lignes. J'ai enregistré mes opérations dans un macro pour essayer de la répeter en boucle sans que j'aille toujours à faire copier/coller transposer des centaines de fois. Par contre, je ne suis pas trop certains de comment automatiser ma macro au maximun pour pas que j'aille à copier les opérations des centaines de fois en changeant toujours mon Range d'orgine et le Range de destinations.:cry:

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17

Sheets("Feuil1").Select Application.CutCopyMode = False Range("A4:A6").Select Selection.Copy Sheets("Feuil2").Select Range("A1").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True   Sheets("Feuil1").Select Application.CutCopyMode = False Range("A12:A14").Select Selection.Copy Sheets("Feuil2").Select Range("A2").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True

---

Merci beaucoup de votre aide :P

Slt,
voici un code qui fonctionne quel que soit le nombre de ligne:

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16

Sub copiercoller() Dim x, y, derligne As Long   y = 1 derligne = Sheets("Feuil1").Range("A65536").End(xlUp).Row   With Sheets("Feuil1") For x = 4 To derligne Step 8 Sheets("Feuil2").Range("A" & y).Value = .Range("A" & x).Value Sheets("Feuil2").Range("B" & y).Value = .Range("A" & x + 1).Value Sheets("Feuil2").Range("C" & y).Value = .Range("A" & x + 2).Value y = y + 1 Next x End With   End Sub

---

Je pense qu'il y a mieux, mais bon ça marche.
A+

Merci Beaucoup

Ça fonctionne super bien :ccool: