Autres Une macro pour transposer des onglets dans un seul onglet à la suite

[lucarn]

Bonjour,
Je suis nouvellement inscrit sur le forum et je vous remercie de m'y accueillir.
Je ne suis pas un grand connaisseur d'Excel, mais, je suis amené à concevoir un outil (Excel 2007)
Il s'agit de fiches action à partir desquelles, je voudrais faire des statistiques.
La question :
Chaque fiche action fait l'objet d'un onglet.
Je veux que chaque fiche action en lignes soit transposé en colonne dans un seul onglet récapitulatif à partir duquel je pourrai faire mes calculs.
J'ai réussi à faire ma première macro pour transposer une fiche action dans l'onglet récapitulatif.
Le problème est que ça ne marche qu'une fois parce que la seconde fois, la fiche vient se coller sur la première.
J'ai donc besoin d'une macro qui permette de transposer chaque fiche les unes en dessous des autres.

Je joins le fichier modèle dans lequel j'ai transposé la 1ère fiche.
Il faut donc que la fiche 2, se transpose d'elle même dans l'onglet récapitulatif, à la ligne 8.
Quelqu'un peut-il me montrer la macro à faire pour que la fiche 2 se colle sur la ligne 8 et que le fiche 3 se colle sur la ligne 12, et ainsi de suite ?
Merci d'avance

 

[sousou]

Bonjour
essaie ceci

Sub cop()
With Sheets("Récapitulatif")
.Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, 50)).Delete
End With
nf = 0
For Each f In Sheets
If Left(f.Name, 5) = "Fiche" Then
Set zone = f.Range(f.Cells(1, 3), f.Cells(50, 7))
Call col(zone, nf)
nf = nf + 1

End If

Next
End Sub

Sub col(zone, nf)
With Sheets("Récapitulatif")
zone.Parent.Activate
zone.Copy
.Cells(nf * 6 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True


End With
End Sub

 

[lucarn]

Bonjour
essaie ceci

Sub cop()
With Sheets("Récapitulatif")
.Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, 50)).Delete
End With
nf = 0
For Each f In Sheets
If Left(f.Name, 5) = "Fiche" Then
Set zone = f.Range(f.Cells(1, 3), f.Cells(50, 7))
Call col(zone, nf)
nf = nf + 1

End If

Next
End Sub

Sub col(zone, nf)
With Sheets("Récapitulatif")
zone.Parent.Activate
zone.Copy
.Cells(nf * 6 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True


End With
End Sub

 

[lucarn]

Bonjour Sousou et merci pour ta réponse.
J'ai donc copié collé ta formule à la place de ma formule de macro.
Je ne sais pas si c'est bien cela qu'il fallait faire.
J'ai un message qui me dit :
"erreur de compilation, End sub attendu"
Bonne journée

 

[sousou]

Bonjour
Tu as certainement oublié quelque chose

 

[lucarn]

Bonjour Sousou,
C'est bon, j'ai réussi.
J'abuse de ton aide.
Toujours, à partir du même doc, je veux prendre certains éléments et les redistribuer dans une feuille rapport.
Je suis passé par enregistrement manuel et donc, j'ai la base des éléments à prendre et celle de leur rangement.
Mon problème est toujours le même, à savoir, que toutes les fiches soient traitées de la même façon les unes en dessous des autres.
Le langage VBA est vraiment difficile pour moi, et je n'ai pas réussi à reprendre dans ta macro, la ou les "phrases" qui indiquent qu'il faut ajouter les fiches les unes derrière les autres en laissant une ligne vierge entre chaque fiche.
Peux-tu me donner la formule ?
Voici la macro que j'ai enregistrée à laquelle je voudrais ajouter la formule :

Sub Transposer_rapport()
'
' Transposer_rapport Macro
'

'
Windows("PERSONAL.XLSB").Activate
Windows("Fiches action Arts vivants.xls").Activate
Range("C7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
Range("D8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
Range("C14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("C4").Select
ActiveSheet.Paste
Range("A5").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Du "
Sheets("Fiche Spectacle").Select
Range("C15").Select
Selection.Copy
Sheets("Rapport").Select
Range("B5").Select
ActiveSheet.Paste
Range("C5").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "au"
Range("C5").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("D5").Select
Sheets("Fiche Spectacle").Select
Range("C16").Select
Selection.Copy
Sheets("Rapport").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
Range("B18:C18").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("A6").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
Range("B19:C19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("D6").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
ActiveWindow.SmallScroll Down:=9
Range("C22").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("A7").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Prestataire"
Range("B7").Select
Sheets("Fiche Spectacle").Select
Selection.Copy
Sheets("Rapport").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
Range("B28:G28").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("A8").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
Range("B29:G30").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("A9").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
ActiveWindow.SmallScroll Down:=25
Range("B45:G47").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("A11").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
Range("B51:G53").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("A14").Select
ActiveSheet.Paste
Sheets("Fiche Spectacle").Select
End Sub

D'avance un grand merci

 

[sousou]

Explique ce que tu souhaites à partir du fichier! le code enregistré c'est trop long
DE bonnes phrases un exemple, et ca doit suffir sinon comment veux-tu qu'on s"y retrouve
et travail avec le même fichier ue celui que tu as poster

 

[Valtrase]

Bonjour l'enregistreur de Macros.....

Windows("Fiches action Arts vivants.xls").Activate
Range("C7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Rapport").Select
Range("A3").Select
ActiveSheet.Paste

Si tu veux que ton code s’exécute plus rapidement évites les .Select et .Activate.
Un simple

WorkSheet("Toto").range("A1").Value = WorkSheet("Truc").Range("B1").Value

C'est ce bout de code qui permet de mettre les fiches les unes derrière les autres

.Cells(nf * 6 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Donc si tu veux une ligne blanche remplace 6 par 7 dans la mesure ou tes fiches se terminent à la colonne G
Merci à sousou pour ce bout de code qui est une approche à laquelle je n'aurais pas pensé.

 

[sylgui2002]

bonjour
essayez ce code là
Private Sub CommandButton1_Click()

Dim lg, ws As Worksheet, f As Worksheet
Set f = Sheets("synthese")
f.Range("a2:d" & f.[a65000].End(xlUp).Row).ClearContents 'efface Récap

For Each ws In Worksheets
If ws.Name <> "Feuil1" And ws.Name <> "synthese" And ws.Name <> "journal mvt" And ws.Name <> "baseadrien" And ws.Name <> "liste site" And ws.Name <> "base nom" And ws.Name <> "recherche par palette" And ws.Name <> "code barre" And ws.Name <> "pc deja reactivés" Then 'feuilles à ne pas traiter
lg = ws.Range("a" & Rows.Count).End(xlUp).Row
ws.Range("a1:e" & lg).Copy Destination:= _
f.Range("a" & Rows.Count).End(xlUp)(2)
End If
Next
Sheets("synthese").Range("E2:e10000").ClearContents
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Feuil1" And ws.Name <> "synthese" And ws.Name <> " journal mvt" And ws.Name <> "baseadrien" And ws.Name <> "liste site" And ws.Name <> "base nom" And ws.Name <> "recherche par palette" And ws.Name <> "code barre" And ws.Name <> "pc deja reactivés" Then
For I = 1 To Sheets("synthese").Range("A1")(Rows.Count, 1).End(xlUp).Row
If Application.CountIf(Sheets(ws.Name).Range("a:a"), Range("a" & I)) = 1 Then Range("e" & I) = ws.Name
Next
End If
Next

il faut modifier les noms des onglets

 

[lucarn]

Explique ce que tu souhaites à partir du fichier! le code enregistré c'est trop long
DE bonnes phrases un exemple, et ca doit suffir sinon comment veux-tu qu'on s"y retrouve
et travail avec le même fichier ue celui que tu as poster

Bonjour Sousou,

Effectivement, je n'ai pas mis le fichier car la macro que j'ai mise je l'ai faite à partir du même fichier que celui sur lequel tu m'as aidé. Valtrase et Silguy m'ont répondu, ça devrait fonctionner. Merci

 

[lucarn]

Bonjour l'enregistreur de Macros.....

Si tu veux que ton code s’exécute plus rapidement évites les .Select et .Activate.
Un simple

WorkSheet("Toto").range("A1").Value = WorkSheet("Truc").Range("B1").Value

C'est ce bout de code qui permet de mettre les fiches les unes derrière les autres

.Cells(nf * 6 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Donc si tu veux une ligne blanche remplace 6 par 7 dans la mesure ou tes fiches se terminent à la colonne G
Merci à sousou pour ce bout de code qui est une approche à laquelle je n'aurais pas pensé.

Bonjour Valtrase,
et merci pour ta réponse.
Cependant, ça ne fonctionne pas, j'ai un message d'erreur.
J'ai essayé 2 solutions
La première où j'ai recopié ta phrase après ma macro. Cela donne

.Cells(nf * 6 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

End Sub

Du coup j'ai repris toute la fin de la formule de Sousou et j'ai donc ajouté cela à ma macro

End If

Next
End Sub

Sub col(zone, nf)
With Sheets("Récapitulatif")
zone.Parent.Activate
zone.Copy
.Cells(nf * 7 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True


End With
End Sub

Mais, j'ai encore un message d'erreur.
Du coup, je suis en stand by. Si tu as quelques minutes...

 

[lucarn]

J'essaye de suivre les conseils de Valtrase, mais je coince dès le premier code qui permet de code qui permet de mettre les fiches les unes derrière les autres dans l'onglet rapport
Voici le code de Valtrase :
WorkSheet("Toto").range("A1").Value = WorkSheet("Truc").Range("B1").Value
Je ne sais par quoi remplacer Toto et Truc.vJ'ai beau avoir essayé plusieurs solutions, ça coince.

Pour récapituler, je veux mettre des éléments de mes onglets "fiche1", "fiche2", "fiche3", etc. " dans l'onglet "rapport".

 

[xUpsilon]

Bonjour,

Toto et Truc doivent être remplacé par les noms des onglets concernés.
Et aussi, je pense que Worksheets("Blablabla") fonctionnera mieux.

Bonne continuation

 

[lucarn]

Bonjour,

Toto et Truc doivent être remplacé par les noms des onglets concernés.
Et aussi, je pense que Worksheets("Blablabla") fonctionnera mieux.

Bonne continuation

Merci xUpsilon. Effectivement, je n'ai plus le message d'erreur. Mais, je suis loin du compte.
Je ne sais pas si tu as regardé la macro que j'ai faite avec l'enregistreur qui consiste à reprendre des éléments des onglets qui s'appellent tous "fiche 1, 2, 3 etc" pour les coller dans l'onglet "rapport" les éléments de fiches les uns derrière les autre et séparés d'une ligne.
Je voulais avoir la formule complète (je n'y connais strictement rien en vba) à coller à la suite de ma macro.
On m'a donné des réponses mais, ça ne fonctionne pas.

 

[sousou]

Bonjour
Alors tu en es où? j'ai un peu de mal à suivre