Assembler plusieurs feuilles

ICE_SACCO

XLDnaute Junior
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
 

Dranreb

XLDnaute Barbatruc
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

XLDnaute Junior
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

XLDnaute Barbatruc
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 !
 
Dernière édition:

ICE_SACCO

XLDnaute Junior
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.
 

ICE_SACCO

XLDnaute Junior
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

XLDnaute Barbatruc
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

XLDnaute Junior
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

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

ScreenShot008.jpg
 

Dranreb

XLDnaute Barbatruc
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

XLDnaute Junior
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
 

Discussions similaires

Réponses
12
Affichages
330
Réponses
14
Affichages
218

Statistiques des forums

Discussions
300 937
Messages
1 988 657
Membres
210 228
dernier inscrit
mowatachi