Regroupement de feuilles 2
Suite et nouvelle requette de :
https://forum.excel-pratique.com/viewtopic.php?t=9538
Bonjour à tous,
Actuellement ce superbe code assemble dans la plage des colonnes A à J de synthese toutes les feuilles 1 à 1 de haut vers le bas. Est-il possible d'obtenir le mème principe d'assemblage mais à la suite de collonnes et non de lignes ? En plus claire feuille 1 de A à J, la feuille 2 de k à ......
Merci par avance de votre aide.
Edit Dan
Bonjour,
Tu veux partir de la feuille Synthèse pour exporter vers toutes les feuilles ou ai-je mal compris ?
Mets un exemple de ce que tu veux, ce sera plus facile de voir la finalité.
Amicalement
Dan
Dan bonjour,
En fait c'est toujours le même fichier. Au lieu de superposé feuille1, feuille2 etc ....
Est-il possible de cumulé feuille 1 sur les colonnes de A à J, la feuille 2 sur les colonnes de k à ...... etc ... sur la page synthese ?
https://forum.excel-pratique.com/viewtopic.php?t=9538
Merci par avance de votre aide
Re,
En se basant sur le code proposé par Myta, essaye ceci :
Sub Synthese_Onglets()
'Macro Dan
Dim Feuille As Worksheet
Dim i As Integer
With Sheets("Synthese")
.Range("A1:J" & Sheets("Synthese").Range("B65535").End(3).Row + 1).Clear
i = .Range("IV1").End(xlToLeft).Column + 1
For Each Feuille In Sheets
If i = 2 Then
i = i - 1
Else: i = .Range("IV1").End(xlToLeft).Column + 1
End If
If Feuille.Name <> "Synthese" Then
Feuille.Range("A1:J" & Feuille.Range("B65535").End(3).Row).Copy Sheets("Synthese").Cells(1, i) 'Range("A" & Sheets("Synthese").Range("B65535").End(3).Row + 1)
End If
Next Feuille
End With
End SubAmicalement
Dan
Bonsoir Nad-Dan,
Merci infiniment pour cette réponse rapide, excellente et précieuse.
Tout nouveau sur ce site, je suis conquis et sans réserve sur la qualité de ce site
ON NE COMPREND PAS = FORUM = PARTAGE = ENTRAIDE et ce par des Pros généreux.
Très sincèrement merci(s).
Nouveau
Trop peu de connaissances en Excel pour me dépatouiller. Ramant à ne plus avancer, je solicite votre aide.
d'après le code proposer ci-dessus :
Sub Synthese_Onglets()
'Macro Dan
Dim Feuille As Worksheet
Dim i As Integer
With Sheets("Synthese")
.Range("A1:J" & Sheets("Synthese").Range("B65535").End(3).Row + 1).Clear
i = .Range("IV1").End(xlToLeft).Column + 1
For Each Feuille In Sheets
If i = 2 Then
i = i - 1
Else: i = .Range("IV1").End(xlToLeft).Column + 1
End If
If Feuille.Name <> "Synthese" Then
Feuille.Range("A1:J" & Feuille.Range("B65535").End(3).Row).Copy Sheets("Synthese").Cells(1, i) 'Range("A" & Sheets("Synthese").Range("B65535").End(3).Row + 1)
End If
Next Feuille
End With
End Sub
Je recherche à obtenir par macro le raisonnement suivant :
Si le contenu de la cellule A2 du feuillet FOS est égal à l'une des cellules de la colonne A du feuilet COG copier l'ensemble de ces deux lignes des deux feuillet dans synthèse,
si A2 du feuillet FOS = 123 par exemple et l'une des cellules du feuillet COG = 123 recopier les lignes dans synthèse.
puis la macro passerait à la cellule B2 du feuillet FOS = etc ........
A savoir que la colonne A de FOS poséderat dans chaque cellule des numeros uniques par exemple de 0 à 9999, jamais deux fois le meme numero et idem dans la colle A du feuillet COG (0 à 9999 et jamais deux numéros identique)
Autre précision si les infos du premier feuillet ne trouvent pas de concordance pour être copiées dans Synthese alors elle ne seraient pas copiées dans le feuillet Synthese ...
Merci pour votre aide, et orientation à la résolution de cette recherche.
Re,
Désolé j'avais perdu ton pb là....
Mets un petit fichier ce sera plus facile d'adapter le code ci-avant.
A te relire
Dan
Bonjour Nad-Dan, et les amis du forum,
Sub AvecCopierColler()
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet, C1 As Byte, C2 As Byte, Derlign As Long
Set Ws1 = Sheets("Feuil1")
Set Ws2 = Sheets("Feuil2")
Set Ws3 = Sheets("Synthese")
Application.ScreenUpdating = False
For i = 2 To Ws1.Range("A65000").End(xlUp).Row
For j = 2 To Ws2.Range("A65000").End(xlUp).Row
If Ws1.Cells(i, 1) = Ws2.Cells(j, 1) Then
Derlign = Ws3.Range("A65000").End(xlUp).Row + 1
With Ws1
C1 = .Cells(i, 1).End(xlToRight).Column
.Range(.Cells(i, 1), .Cells(i, C1)).Copy
Ws3.Cells(Derlign, 1).PasteSpecial Paste:=xlValues
End With
With Ws2
C2 = .Cells(i, 1).End(xlToRight).Column
.Range(.Cells(j, 2), .Cells(j, C2)).Copy
Ws3.Cells(Derlign, C1 + 1).PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
End If
Next
Next
Application.ScreenUpdating = True
End SubEst-il possible d'obtenir le même résultat mais avec en plus ...
https://www.excel-pratique.com/~files/doc/NOUVEAUv2.xls
Le repport est parfait il assemble ce qui correspond, mais je voudrais maintenant que la macro ajoute également en fin de fichier ou chronologiquement de la page synthese les lignes de la feuil1 et de la feuil2 qui ne serait pas condensée dans la synthese actuelle ?
Précision du raisonnement !
SI info d'une ligne de la feuil1 = à celle de la feuil2 repport assemblé sur feuille de synthese (résultat de la macro actuelle)
SI info d'une ligne de la feuil1 différente (ne se retrouve pas dans la feuil2) de feuil2 = repport partie feuil1 à la fin de feuille de synthese en fin de fichier ou a la suite chronologiquement.
et vis-versa si feuil2 différente de feuil1 = repport partie feuil2 à la fin de la feuille de synthese (en fin de fichier ou a la suite chronologiquement).
Précision également importante dans les colonnes A des feuil1 et feuil2 il n'y aura jamais les mêmes lettres ou chiffres (jamais deux cases avec les mêmes infos).
Base dispo :
https://www.excel-pratique.com/~files/doc/NOUVEAUv2.xls
A+ et merci pour tout conseils.
NOUVEAU
Le sujet me semblait très intérressant. Avec Excel n'est-il pas possible de fournir de tel possibilité ?
Help svp ......
NOUVEAU
Bonsoir
Ce code :
Code:
Sub AvecCopierColler()
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet, C1 As Byte, C2 As Byte, Derlign As Long
Set Ws1 = Sheets("Feuil1")
Set Ws2 = Sheets("Feuil2")
Set Ws3 = Sheets("Synthese")
Application.ScreenUpdating = False
For i = 2 To Ws1.Range("A65000").End(xlUp).Row
For j = 2 To Ws2.Range("A65000").End(xlUp).Row
If Ws1.Cells(i, 1) = Ws2.Cells(j, 1) Then
Derlign = Ws3.Range("A65000").End(xlUp).Row + 1
With Ws1
C1 = .Cells(i, 1).End(xlToRight).Column
.Range(.Cells(i, 1), .Cells(i, C1)).Copy
Ws3.Cells(Derlign, 1).PasteSpecial Paste:=xlValues
End With
With Ws2
C2 = .Cells(i, 1).End(xlToRight).Column
.Range(.Cells(j, 2), .Cells(j, C2)).Copy
Ws3.Cells(Derlign, C1 + 1).PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
End If
Next
Next
Application.ScreenUpdating = True
End Sub si sur une mème ligne la cellule de "Feuil1" est = à ("Feuil2") repport sur la "Synthese"
idem
si sur une mème ligne la cellule de "Feuil2" est = à ("Feuil1") repport sur la "Synthese"
et ainsi de suite ...
Maintenant je cherche à obtenir et ni arrivant pas je sollicite encore une fois votre aide :
si sur une mème ligne la cellule de "Feuil1" est différente à ("Feuil2") repport sur la "Synthese"
idem
si sur une mème ligne la cellule de "Feuil2" est différente à ("Feuil1") repport sur la "Synthese"
et ainsi de suite ...... et donc ne repporte plus les identiques ..... mais uniquement que les différents.
Merci(s) / NOUVEAU