Microsoft 365 Copier depuis plusieurs pages d'un fichier une plage de colonnes entre deux cellules comportant un texte particulier

[softy69]

Bonjour à tous,

Je me lance dans un projet de simplification de process Excel en passant par les macros.

Mise en contexte :
Je dispose d'un fichier de X feuilles, sur chaque feuille la partie qui m'intéresse est celle de droite (les 6 dernières colonnes remplies). Je voudrais trouver le code pour identifier cette zone pour chaque feuille. Mon but, une fois cette étape franchie, est de copier cette zone (depuis chaque feuille) et les coller les une en dessous des autres dans une feuille vierge préalablement créée.

Problèmes que je rencontre :
- "Les 6 dernières colonnes" n'ont pas la même adresse sur toutes les feuilles.
- La première ligne des 6 colonnes est une cellule fusionnée avec les 6 colonnes. Cette cellule est non importante à copier.
==> la deuxième ligne des 6 colonnes est une ligne d'en-tête, contenant dans chaque cellule que du texte et ces cellules sont identiques sur toutes les feuilles. (Je me disais qu’utiliser cette plage de valeur en référence serait utile).

Je peux vous joindre un extrait de mon fichier anonymisé et réduit à 3 feuilles pour expliciter mon texte si le projet vous tente. Je profite pour vous dire que le nombre de feuilles peut atteindre 200/250.

Merci d'avance pour votre aide et/ou propositions.

 

[soan]

Bonjour softy69,

Si par exemple ta ligne d'en-têtes est en ligne 3, alors :

dcol = Cells(3, Columns.Count).End(1).Column

retourne le n° de la dernière colonne utilisée, selon la ligne 3 ; par exemple : 16
et donc dcol - 5 est le n° de la 1ère colonne du groupe de 6 colonnes qui est
au bout à droite : 16 - 5 = 11 ; et dans cet exemple, les 6 dernières colonnes
sont bien de 11 à 16.

.End(1) est la même chose que .End(xlToLeft) ; c'est plus juste plus court à écrire et à lire.

S'il y a des fusions, ça sera à adapter ; il vaut mieux que tu joignes ton fichier exemple,
anonymisé et réduit, pour qu'on puisse travailler sur quelque chose de plus concret.

soan

 

[softy69]

Bonjour soan

Merci beaucoup pour ta réponse, je vais tester ça de suite et reviens vers vous...

"S'il y a des fusions, ça sera à adapter ; il vaut mieux que tu joignes ton fichier exemple,
anonymisé et réduit, pour qu'on puisse travailler sur quelque chose de plus concret."

En attendant ci-joint le fichier si ça peut inspirer.

Merci encore.

 

[soan]

Ton fichier en retour ; sur chaque feuille, fais Ctrl e

Tu verras que pour ça, je n'ai pas eu besoin de faire
d'adaptation selon les fusions de cellules.

soan

 

[softy69]

soan,
mon fichier fait plus de 200 pages et d'un projet a un autre il peut y en avoir moins ou plus.

Ce que je voudrais c'est :

Dire sous forme de boucle à incrémentation : copie "ça"depuis la feuilles en position 1 et colle-le dans la feuille nommée "PASTE"en colonne A première cellule vide puis idem feuille en position 2 et idem feuille en position 3 ....

 

[soan]

essaye d'abord le fichier de mon post précédent,
et donne-moi ton avis dessus.

soan

 

[softy69]

Ton fichier en retour ; sur chaque feuille, fais Ctrl e

Nickel, les coordonnées sont bonnes mais on en fait quoi ? Je suis un poil largue...

Pour chaque feuille on lance tes lignes magiques , et on se sert des valeurs qui en ressorte pour définir les zones à sélectionner puis copier puis coller ?

 

[soan]

oui, c'est bien ça ; plus en détail :

* se servir de coID pour la 1ère colonne "ID"

* se servir de coDsc pour la colonne "Description"

* se servir de coID + le décalage indiqué pour les autres colonnes
(le décalage étant indiqué par un chiffre comme +1, ou +5)

et c'est avec ça que tu as les bonnes références de cellules pour la source
(ce qui est à copier) ; reste plus qu'à le coller à la bonne destination.

tout c'que j'ai écrit au-dessus, c'est pour une feuille donnée, donc pour
chaque feuille, fais ton copier/coller à l'aide de ces infos.

soan

 

[softy69]

* se servir de coID pour la 1ère colonne "ID"

* se servir de coDsc pour la dernière colonne "Description"

* se servir de coID + le décalage indiqué pour les autres colonnes
(le décalage étant indiqué par un chiffre comme +1, ou +5)

et c'est avec ça que tu as les bonnes références de cellules pour la source
(ce qui est à copier) ; reste plus qu'à le coller à la bonne destination.


wooooaaahh super ! En vrai avec cette technique tu es dieu du copie/coller.


Merci énormément je vais travailler ça et voir si je peux le faire avec toutes les feuilles via une boucle. J'ai aucune idée de comment le construire la ...

 

[soan]

alors essaye déjà toi ; si tu y arrives tout seul, tant mieux !

sinon, envoie un fichier en précisant où doit être fait le coller,
et à partir de quelle ligne : peut-être 3 ? ou autre ?

soan

 

[softy69]

Voilà dans l'esprit le code global que je voudrais obtenir mais ne fonctionne pas sur le fichier avec toutes les feuilles.

En revanche il tourne Nickel sur le fichier avec 3 feuilles

Sub boucle()



On Error Resume Next

Application.ScreenUpdating = False

Application.DisplayAlerts = False



'je suprime la feuille paste (si deja existente)

Worksheets("PASTE").Delete





'Déclare les variables



Dim Ws As Worksheet

Dim der As Long

Dim derniereligne As Long

Dim derniercolonne As Integer



'je suprime les feuilles vides





For Each Ws In Application.Worksheets

    If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then

        Ws.Delete

    End If

Next



'je suprime les images

'si autre fonction pour dire garder que text, je veux bien



Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each Ws In ActiveWorkbook.Worksheets

      For Each pic In Ws.Pictures

        pic.Delete

      Next pic

Next Ws

    

Application.ScreenUpdating = True

Application.DisplayAlerts = True



'ajoute la nouvelle Feuille PASTE tout au début du Classeur

Sheets.Add Before:=Worksheets(1)

Sheets(1).Name = "PASTE" '





'Boucle sur toutes les feuille de calcul du classeur.

'Les onglets graphiques ne sont pas pris en compte.



'ThisWorkbook correspond à l'objet classeur contenant la macro

For Each Ws In ActiveWorkbook.Worksheets

    If Ws.Name <> "PASTE" Then

   der = Worksheets("PASTE").Cells(Rows.Count, "A").End(xlUp).Row + 1

derniereligne = Ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row

derniercolonne = Ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column

Ws.Range(Ws.Cells(2, derniercolonne - 10), Ws.Cells(derniereligne, derniercolonne)).Copy _

    Destination:=Worksheets("PASTE").Range("A" & der)

    End If

Next Ws



'je suprime les lignes blanche ou contenant title en A



 For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1

             If Cells(i, 1) = "" Or Cells(i, 1) = "TITLE" Then

             Rows(i).Delete

              End If

       Next i



End Sub

 

[soan]

tu as oublié de mettre un fichier exemple, avec quelques données fictives !

soan

 

[softy69]

tu as oublié de mettre un fichier exemple, avec quelques données fictives !

soan

Le fichier avec 3 feuilles est au dessus, je le remet ici si tu veux. En revanche le fichier globale je ne peux pas le diffuser. si adresse mail ok

 

[soan]

Bonjour @softy69,

D'abord, vérifie que les données à copier sont jusqu'à la ligne :

* 18 pour la feuille "Table 48"
* 15 pour la feuille "Table 3"
* 9 pour la feuille "Table 1"

exact, n'est-ce pas ? bon, alors continuons :

* va sur la feuille "PASTE" (qui doit être toujours la 1ère feuille)
* note bien que cette feuille est entièrement vide
* fais Ctrl e ➯ travail effectué

------------------------------------------------------------------------------------

Pour les 3 tableaux, tu peux voir qu'il y a bien la ligne d'en-têtes
(de "ID" à "Description"), ainsi que la ligne de fin de tableau, celle
qui commence par "DXXXX".

------------------------------------------------------------------------------------

Vérifions maintenant, pour chaque tableau le nombre de lignes de détail :

* celui de "Table 1" : c'est ok, il y a bien 7 lignes

* celui de "Table 3" : il y a seulement 9 lignes au lieu de 12 ! pourquoi ?
car en ligne 12, tu as une ligne vide intercalaire ➯ fin du tableau, et
les lignes de détail 10 à 12 ne sont pas copiées

* celui de "Table 48" : il n'y a que 2 lignes, et en plus la 1ère ligne est vide !
pourquoi ? toujours à cause de lignes vides intercalaires qui ne devraient
pas être là ! elles sont en lignes 3 et 6, et il y en a d'autres dessous

* sans ces lignes vides intercalaires, la macro aurait fait un travail correct
pour tous les tableaux, comme ça l'a fait pour le 1er tableau

------------------------------------------------------------------------------------

regarde de nouveau "Table 3" ; la méthode que j'ai utilisée pour trouver
quelle est la dernière ligne est « à partir de la 2ème ligne, vers le bas » :

dlg = .Cells(2, coID).End(4).Row ; .End(4) = .End(xlDown)

à cause de la ligne vide intercalaire qui a le n° 12, ça s'arrête en ligne 11 ;
et si on essayait à partir du bas, vers le haut ? ça aurait pu être une très
bonne idée, sauf que c'est pas possible à cause de tes cellules fusionnées,
comme Q16:AA21 ; alors avec toutes tes lignes vides intercalaires et tes
très nombreuses fusions de cellules, ça devient impossible ! alors à toi
d'arranger tout ça ! (bonne chance, car y'a du boulot !!! )

soan

 

[softy69]

@soan, Merci pour tes conseils avisés,

j'ai adapté le code comme ci-dessous et ça à l'air de fonctionner sur mon fichier racine (avec les 200 feuilles).

Demain je fais une vérification de toutes les feuilles pour m'assurer que j'ai bien toutes les infos et je reviens avec une confirmation (je l'espère)et un fichier de démo

Option Explicit

Dim nlm&, lg2&
-----------------------------------------------------------------------------------------
Private Sub Job(i%)
  Dim coID%, dlg&
  With Worksheets(i)
    coID = .Cells(2, Columns.Count).End(1).Column - 6
    dlg = .Cells(2, coID).End(4).Row
    .Cells(2, coID).Resize(dlg - 1, 11).Copy Cells(lg2, 1)
    lg2 = lg2 + dlg - 1
    dlg = .Cells(nlm, coID).End(3).Row
    .Cells(dlg, coID).Resize(, 11).Copy Cells(lg2, 1)
    Cells(lg2, 1).Resize(, 11).Borders.LineStyle = 1
    lg2 = lg2 + 1
  End With
End Sub
--------------------------------------------------------------------------------------------

Sub CpyTbl()

Dim P As Long
Dim Ws As Worksheet

On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each Ws In Application.Worksheets
    If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then
        Ws.Delete
    End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True

For Each Ws In ThisWorkbook.Worksheets
    For P = Range("A65536").End(xlUp).Row To 1 Step -1
If Application.CountA(Rows(P)) = 0 Then Rows(P).Delete Shift:=xlUp

Next
Next

Sheets.Add Before:=Worksheets(1)
Sheets(1).Name = "PASTE" '

  Dim i%: Application.ScreenUpdating = 0
  Worksheets("PASTE").Select: Cells.Clear
  nlm = Rows.Count: lg2 = Cells(nlm, 1).End(3).Row + 1
  If lg2 = 2 And [A1] = "" Then lg2 = lg2 - 1
  For i = 2 To Worksheets.Count: Job i: Next i
  Cells(lg2 + 1, 1).Select: Application.CutCopyMode = 0
 
MsgBox ("MTO ESTABLISHED !")
End Sub