Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Assembler plusieurs feuilles

I

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
 
Trier par date Trier par votes
I

ICE_SACCO

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

Pièces jointes

  • Web Portefeuille_activite_MOPO_TRANSV_EXPINF.xlsm
    411.7 KB · Affichages: 34
Vote positif 0 Vote négatif

Dranreb

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif

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.
 
Vote positif 0 Vote négatif
I

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
 
Vote positif 0 Vote négatif

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:
Vote positif 0 Vote négatif
I

ICE_SACCO

XLDnaute Junior
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.
 
Vote positif 0 Vote négatif
I

ICE_SACCO

XLDnaute Junior
Dranreb à dit:
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.
Cliquez pour agrandir...
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 ...
 
Vote positif 0 Vote négatif

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…
 
Vote positif 0 Vote négatif
I

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
I

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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
595
laurent950
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
250
vgendron
G
  • Question
Microsoft 365 Export données
Réponses
4
Affichages
453
GClaire
G
D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
1 K
Dranreb
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
372
CathyLD
C
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
528
AtTheOne
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
N
  • Question
Microsoft 365 Remplissage automatique d'une feuille à l'autre
Réponses
2
Affichages
220
Nonoo
N
R
  • Question
XL 2019 Demande à la macro de chercher et de remplir automatiquement jusqu'à la dernière valeur
Réponses
1
Affichages
439
Aya_flo
A
M
  • Question
XL 2010 Aide à la suppression d'un produit en double dans un magasin spécifique avec conditions
Réponses
9
Affichages
733
Mody200
M
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…