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

softy69

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

XLDnaute Accro
Bonjour softy69,

Si par exemple ta ligne d'en-têtes est en ligne 3, alors :
VB:
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

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

Fichiers joints

softy69

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

softy69

XLDnaute Nouveau
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 o_O, et on se sert des valeurs qui en ressorte pour définir les zones à sélectionner puis copier puis coller ?
 

soan

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

XLDnaute Nouveau
* 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

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

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


VB:
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

XLDnaute Accro
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 !!! :eek::eek:o_Oo_O)


soan
 

Fichiers joints

softy69

XLDnaute Nouveau
@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

VB:
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
 

softy69

XLDnaute Nouveau
Bonjour a tous,

Après vérification ce qui pose problème maintenant c'est les cellules fusionnée et les lignes blanches, comme l'a souligné @soan .

Je suis à la recherche de ligne de code qu'on pourrait utiliser, pour dire :
"sur chaque feuille de ce classeur
sélectionner toutes les cellules de la feuille
si la cellule est fusionnée alors defusionner
cellule suivante
feuilles suivant"

À la suite de ce code je viendrai supprimer les ligne blanches et dérouler la sélection de zones à copier/coller et le faire sur la feuille PASTE précédemment créé.

Merci pour votre aide
 

softy69

XLDnaute Nouveau
Wow quelle réactivité !

Merci a toi, ca fonctionne tres bien. En revanche quand je l'integre avec les autres operations je me rends compte que c'est la fonction "suprimer les ligne blanches de toutes les feuilles" qui cloche... :mad:.

Est-ce que tu aurais une idee ?


VB:
sub cleaning()
Dim P As Long
Dim Ws As Worksheet
Dim sh 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


Application.ScreenUpdating = False
    For Each sh In Worksheets: sh.Cells.UnMerge:
    Next
Application.ScreenUpdating = True

    For Each Ws In Worksheets: Ws
    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
    
end sub
 

soan

XLDnaute Accro
Voici ton code corrigé et optimisé (ça a été très long à faire !) :
VB:
Option Explicit

Sub cleaning()
  On Error Resume Next
  Dim Ws As Worksheet, lig&, k&, n%, i%: n = Worksheets.Count
  Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
  For Each Ws In Application.Worksheets
    If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then Ws.Delete
  Next Ws
  For i = 1 To n
    With Worksheets(i)
      .Cells.UnMerge: k = .[A65536].End(3).Row
      For lig = k To 1 Step -1
        If Application.CountA(.Rows(lig)) = 0 Then .Rows(lig).Delete 3
      Next lig
    End With
  Next i
  Application.DisplayAlerts = -1
End Sub
Attention : pour le 1er .CountA c'est ok ; pour le 2ème, même si la compilation est ok,
je ne suis pas sûr que ton Application.CountA() soit correct à l'exécution ; ce sera
peut-être plutôt : Application.WorksheetFunction.CountA(.Rows(lig))

Note que maintenant, il y a 2 boucles For au lieu de 3 ; d'autre part, avec ton code VBA,
des opérations ne se faisaient que sur la feuille active car tu avais oublié de préfixer
avec Ws (dans la 3ème boucle For).


soan
 
Dernière édition:

soan

XLDnaute Accro
Edit n° 1 : attention, n'utilise pas le code VBA ci-dessus ; j'ai fait une très grosse erreur !
attends un moment, je vais la corriger.

Edit n° 2 : dans le post #19 ci-dessus, j'ai remplacé mon ancien code VBA (qui avait
un très gros bug)
par le bon code VBA ; maintenant, c'est OK. :)
 
Dernière édition:

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas