Assembler plusieurs feuilles

[ICE_SACCO]

Bonjour,

Je cherche à assembler plusieurs feuilles en récupérent chaque ligne pour les mettre dans une feuille commune.

Mon problème cela me récupère que une ligne par feuil même s'il y en a plusieurs. Et j'aimerai aussi que pour chaque ligne il y est une mise en page cadrillage

'Début assemblage

Dim i As Long, j As Long 'Déclare deux variables numériques
Worksheets("Portefeuille Projet").Select 'Active la feuille nommée SYNTHESE
'Passe chaque feuille en revue en partant de la 3eme jusqu'à n
For i = 3 To Worksheets.Count - 1 'WorkSheets.Count donne le nombre total de feuilles moins la dernière
'j prend la valeur du numéro de ligne de la 1ere cellule vide de la colonne A
'A chaque passage dans la boucle j sera incrémentée de 1 du fait de l 'inscription des nouvelles données
j = Range("A65536").End(xlUp).Row + 1
With Worksheets(i)
'Sur la ligne déterminée par j, la 1ere cellule prend la valeur de la cellule A1 de la feuille dont l'index est égal à i
Cells(j, 1).Value = .Range("A3").Value
Cells(j, 2).Value = .Range("B3").Value
Cells(j, 3).Value = .Range("C3").Value
Cells(j, 4).Value = .Range("D3").Value
Cells(j, 5).Value = .Range("E3").Value
Cells(j, 6).Value = .Range("F3").Value
Cells(j, 7).Value = .Range("G3").Value
Cells(j, 8).Value = .Range("H3").Value
Cells(j, 9).Value = .Range("I3").Value
Cells(j, 10).Value = .Range("J3").Value
Cells(j, 11).Value = .Range("K3").Value
Cells(j, 12).Value = .Range("L3").Value
Cells(j, 13).Value = .Range("M3").Value
Cells(j, 14).Value = .Range("N3").Value
Cells(j, 15).Value = .Range("O3").Value
Cells(j, 16).Value = .Range("P3").Value
Cells(j, 17).Value = .Range("Q3").Value
Cells(j, 18).Value = .Range("R3").Value
Cells(j, 19).Value = .Range("S3").Value
Cells(j, 20).Value = .Range("T3").Value
Cells(j, 21).Value = .Range("U3").Value
Cells(j, 22).Value = .Range("V3").Value
Cells(j, 23).Value = .Range("W3").Value
Cells(j, 24).Value = .Range("X3").Value
Cells(j, 25).Value = .Range("Y3").Value
Cells(j, 26).Value = .Range("Z3").Value
Cells(j, 27).Value = .Range("AA3").Value
Cells(j, 28).Value = .Range("AB3").Value
Cells(j, 29).Value = .Range("AC3").Value
Cells(j, 30).Value = .Range("AD3").Value
Cells(j, 31).Value = .Range("AE3").Value
Cells(j, 32).Value = .Range("AF3").Value
Cells(j, 33).Value = .Range("AG3").Value
Cells(j, 34).Value = .Range("AH3").Value
Cells(j, 35).Value = .Range("AI3").Value
Cells(j, 36).Value = .Range("AJ3").Value
Cells(j, 37).Value = .Range("AK3").Value
Cells(j, 38).Value = .Range("AL3").Value
Cells(j, 39).Value = .Range("AM3").Value
End With
Next 'Passe à la feuille suivante

Merci d'avance

 

[ICE_SACCO]

L'objectif est de copier toutes les lignes de chaque feuille donc oui vide car comme mentionné "confidentialité" donc j'ai rempli la première colonne ...

 

[gosselien]

L'objectif est de copier toutes les lignes de chaque feuille donc oui vide car comme mentionné "confidentialité" donc j'ai rempli la première colonne ...

ça , on la faite déjà depuis longtemps...il suffit de faire une copie et puis de changer ce qui ne doit pas être connu mais..

perso, je passe mon tour

 

[Dranreb]

Le classeur ne contient pas le code que j'ai indiqué, je ne peux donc pas voir ce qui ne va pas.
Mais si certaines feuilles peuvent être vides il pourrait être indiqué de soumettre l'instruction à un If NbLignes > 0 Then

 

[ICE_SACCO]

Non pas de classeur vide je joins le fichier avec la Macro.

 

[Dranreb]

Vous auriez du voir lors de l'arrêt que NbLignes = -1
Donc il faut le test.
Curieux que vous le fassiez commencer à i = 3 parce qu'un espion sur Worksheets(i).Name dit "Portefeuille Projet"
Effectivement il n'y que des titres, elle est vide et du coup NbLignes = 1 - 2 soit -1.

 

[ICE_SACCO]

Bonjour,

Oui je n'avais pas vu pour le Nblignes comme je débute en VBa ....

Par contre si j'ai bien compris je dois prendre toutes les conditions supérieures à NbLignes > -1 ou 0

Lorsque je teste avec les deux solutions même err et l'arrêt me signale toujours une valeur Nblignes -1

Dim i As Long, j As Long, NbLigne As Long


Worksheets("Portefeuille Projet").Select 'Active la feuille nommée Portefeuille Projet
j = Range("A65536").End(xlUp).Row + 1
For i = 3 To Worksheets.Count - 1
With Worksheets(i)
If NbLignes > 0 Then
NbLignes = .[A1000000].End(xlUp).Row - 2

Cells(j, 1).Resize(NbLignes, 39).Value = .[A3].Resize(NbLignes, 39).Value
j = j + NbLignes
End If
End With

Next i

End Sub 'Fin

 

[Dranreb]

Non. Faites le test après l'avoir calculé, pas avant !
Et surtout vérifiez si ce n'est pas plutôt For i = 4 To Worksheets.Count - 1
Je trouve déjà bizarre que vous ne commenciez pas à j = 2, vous êtes sûr de vouloir préserver ce qui pourrait déjà exister dans la feuille résultante ?
Mais en tout cas commencer par y empiler une copie de son propre contenu, ça ça me paraît n'importe quoi !

 

[ICE_SACCO]

Non. Faites le test après l'avoir calculé, pas avant !
Et surtout vérifiez si ce n'est pas plutôt For i = 4 To Worksheets.Count - 1
Je trouve déjà bizarre que vous ne commenciez pas à j = 2, vous êtes sûr de vouloir préserver ce qui pourrait déjà exister dans la feuille résultante ?
Mais en tout cas commencer par y empiler une copie de son propre contenu, ça ça me paraît n'importe quoi !

Bonjour le i correspond à ma 3 ieme de chaque feuille. Le code fonctionne avec :
Dim i As Long, j As Long, Nblignes As Long


Worksheets("Portefeuille Projet").Select 'Active la feuille nommée Portefeuille Projet
j = Range("A1000").End(xlUp).Row + 1
For i = 3 To Worksheets.Count - 1
With Worksheets(i)
Nblignes = .[A1000000].End(xlUp).Row
If Nblignes > 1 Then
Cells(j, 1).Resize(Nblignes, 39).Value = .[A3].Resize(Nblignes, 39).Value
j = j + Nblignes
End If
End With
Next i
End Sub 'Fin


Merci pour votre aide cela m'a bien aidé il me reste plus qu'a savoir comment chaque ligne récupérée peut avoir des bordures sans que cela me quadrille toute la page.

 

[Dranreb]

Non. Vous mélangez tout. Le i c'est votre compteur index de feuille. Et la feuille d'index 3 c'est "Portefeuille Projet", c'est à dire la feuille résultante.

 

[ICE_SACCO]

Non. Vous mélangez tout. Le i c'est votre compteur index de feuille. Et la feuille d'index 3 c'est "Portefeuille Projet", c'est à dire la feuille résultante.

Oui désolé oui je veux a partir de la troisième et jamais la dernière -1.

Par contre j'ai juste un souci c'est qu'entre chaque lecture de feuille dans Portefeuille Projet il me rajoute une ligne à vide. Le fait de partir à +1 dès le départ pose problème mais je ne vois pas comment le compenser dans la boucle ensuite en faisant J=J-1 ...

 

[Dranreb]

Eh bien faites J = J + NbLignes + 1 à la fin.
Mais j'ai l'impression que vous ne comprenez rien à ce que je dis.
Dans le classeur que vous aviez joint, la première feuille qui suivait la "Portefeuille Projet" c'était Worksheets(4), pas Worksheets(3). Parce que Worksheets(3) c'était "Portefeuille Projet". Mais peut être que dans votre vrai classeur c'est bon, je ne sais pas. Ou peut être que vous voulez l'inclure ? et avoir en double ce qu'elle contient déjà, puis en quadruple si vous le réexécutez, puis 8 fois, 16 fois etc…

 

[ICE_SACCO]

Voici la dernière version de mon code

Sub Assembler()

'Eviter l'ajout des mêmes lignes erase feuille avant lancement
With Worksheets("Portefeuille Projet")
.Rows("2:65536").EntireRow.Delete
End With

'Date de dernière mise à jour

Range("AR1").Value = Format(Now, "dd/mm/yyyy HH:MM")

'Début assemblage
'Déclaration Variables
Dim i As Long, j As Long, Nblignes As Long


Worksheets("Portefeuille Projet").Select 'Active la feuille nommée Portefeuille Projet
j = Range("A1000").End(xlUp).Row + 1
For i = 4 To Worksheets.Count - 1

With Worksheets(i)


Nblignes = .[A1000000].End(xlUp).Row

If Nblignes > 0 Then

Cells(j, 1).Resize(Nblignes, 45).Value = .[A3].Resize(Nblignes, 45).Value

j = j + Nblignes - 1


End If
End With

Next i

End Sub 'Fin

Le problème est qu'aléatoirement entre 2 feuilles il me rajoute une ligne vide

 

[gosselien]

Pourrais-tu déjà mettre ton code entre les balises... ? 4e icone en partant de la petite flèche à droite (haut du panneau)

 

[Dranreb]

Non, je me suis trompé je croyais que vous vouliez une ligne vide en plus pour les séparer.
Il ne faut pas toucher au j = j + NbLignes.
Par contre, puisque vous récupérez toujours à partir de la ligne 3 il faut toujours enlever les 2 lignes qui précèdent. Pourquoi avez vous changé ça ? Ça toit toujours être : Nblignes = .[A1000000].End(xlUp).Row - 2

 

[ICE_SACCO]

Le fait de faire la modification -2 écrase des récupérations précédente ici je récupère les lignes de feuille CH,Cristal mais entre les deux plus rien.

Sub Assembler()

'Eviter l'ajout des mêmes lignes erase feuille avant lancement
With Worksheets("Portefeuille Projet")
.Rows("2:65536").EntireRow.Delete
End With

'Date de dernière mise à jour

Range("AR1").Value = Format(Now, "dd/mm/yyyy HH:MM")

'Début assemblage
'Déclaration Variables
Dim i As Long, j As Long, Nblignes As Long


Worksheets("Portefeuille Projet").Select 'Active la feuille nommée Portefeuille Projet
j = Range("A1000").End(xlUp).Row + 1
For i = 4 To Worksheets.Count - 1

With Worksheets(i)

Nblignes = .[A1000000].End(xlUp).Row - 2

If Nblignes > 0 Then

Cells(j, 1).Resize(Nblignes, 45).Value = .[A3].Resize(Nblignes, 45).Value

j = j + Nblignes


End If
End With

Next i

End Sub 'Fin