Autres Récupérer une partie des données et les consolider

[Oliver77]

Bonjour,

Je m'exerce a créer une macro me permettant de récupérer uniquement les commentaires de mes
feuilles de travail.
La difficulté est que la longueur de la feuille n'est jamais la même.
---------
Sheets("synthese").Columns("A:H").Delete Shift:=xlToLeft

For s = 1 To Sheets.Count - 1
Range(Sheets(s).[A2], Sheets(s).[A65000].End(xlUp).End(xlToRight)).Copy _
[A65000].End(xlUp).Offset(4, 0)
Next s
On Error Resume Next

Sheets("synthese").DrawingObjects.Delete
----------

Vous remerciant par avance pour votre aide,
Olivier77

 

[Oliver77]

😉J'avance à petits pas.

J'ai sais comment trouver la cellule avec "commentaires".
-> Cells.Find(What:="Commentaires").Select

Avec la solution suivante j'arrive à sélectionner une plage conséquente (je sais, ce n'est pas très académique).
-> Cells.Find(What:="Commentaires").Select
Range(ActiveCell, ActiveCell.Offset(50, 4)).Copy

Je continue mes recherches...😛

 

[job75]

Bonjour Oliver77, le forum,

Voyez le fichier joint et cette macro dans le code de la feuille "synthese" :

Private Sub Worksheet_Activate()
Dim deb&, lig&, w As Worksheet, i As Variant, h&
Application.ScreenUpdating = False
deb = 9 '1ère ligne de destination, modifiable
Rows(deb & ":" & Rows.Count).Delete 'RAZ
lig = deb
For Each w In Worksheets
    If w.Name <> Me.Name Then
        Cells(lig, 1) = w.Cells(4, 1) 'titre
        Cells(lig, 1).Font.Bold = True 'en gras
        lig = lig + 2
        i = Application.Match("Commentaires", w.Columns(1), 0)
        If IsNumeric(i) Then
            h = w.UsedRange.Rows.Count - i
            If h Then w.Cells(i + 1, 1).Resize(h).Copy Cells(lig, 1)
            lig = lig + h + 1 'ajout d'une ligne vide
        End If
    End If
Next w
'---supprime les lignes vides excédentaires---
For lig = lig To deb + 1 Step -1
    If Cells(lig, 1) & Cells(lig - 1, 1) = "" Then Rows(lig).Delete
Next lig
End Sub

Elle se déclenche quand on active la feuille.

A+

 

[Oliver77]

🙂Bonjour à tous,

Merci beaucoup, je vais l'étudier...

 

[Oliver77]

Re-bonjour,🙂

J'ai intégré la macro dans mon fichier perso et elle marche.
L'inconvénient est qu'elle prend en compte toutes les feuilles de mon classeur.
Je n'y avais pas pensé...😳
Comment faire pour éviter les feuilles sans commentaires ?

Merci d'avance,
Oliver77

 

[job75]

Comment faire pour éviter les feuilles sans commentaires ?

Il suffit de décaler les 3 lignes de code du titre, fichier (2) :

Private Sub Worksheet_Activate()
Dim deb&, lig&, w As Worksheet, i As Variant, h&
Application.ScreenUpdating = False
deb = 9 '1ère ligne de destination, modifiable
Rows(deb & ":" & Rows.Count).Delete 'RAZ
lig = deb
For Each w In Worksheets
    If w.Name <> Me.Name Then
        i = Application.Match("Commentaires", w.Columns(1), 0)
        If IsNumeric(i) Then
            Cells(lig, 1) = w.Cells(4, 1) 'titre
            Cells(lig, 1).Font.Bold = True 'en gras
            lig = lig + 2
            h = w.UsedRange.Rows.Count - i
            If h Then w.Cells(i + 1, 1).Resize(h).Copy Cells(lig, 1)
            lig = lig + h + 1 'ajout d'une ligne vide
        End If
    End If
Next w
'---supprime les lignes vides excédentaires---
For lig = lig To deb + 1 Step -1
    If Cells(lig, 1) & Cells(lig - 1, 1) = "" Then Rows(lig).Delete
Next lig
End Sub

Si vous ne voulez pas que soit utilisé "Autres comptes" dites-le.

 

[Oliver77]

Encore merci,
Je ne souhaite pas utiliser "autres comptes" car j'ai plusieurs feuilles dans ce cas et je me retrouve avec plusieurs titres qui se suivent.

J'ai essayé la macro et suis vraiment bluffé...

J'ai bien vu que le code a légèrement changé mais j'en suis encore à m'arracher la barbe.

 

[Oliver77]

Re-bonjour,

J'ai faits de nouveaux tests et j'ai compris la macro.
En fait, si je ne précise pas commentaires dans la feuille (colonne A) alors la feuille est ignorée.
Génial.😀😀😀
Par curiosité, j'aimerai voir ce que cela donne si dans la feuille j'oublie d'enlever "commentaires" alors qu'il n'y en a pas.
J'ai aussi poussé ma curiosité avec les calculs et là c'est la formule qui est reportée en synthèse et non le résultat.

Vraiment merci.

 

[job75]

Je ne souhaite pas utiliser "autres comptes" car j'ai plusieurs feuilles dans ce cas et je me retrouve avec plusieurs titres qui se suivent.

Dans ce cas c'est un peu plus compliqué, la macro du fichier (3) :

Private Sub Worksheet_Activate()
Dim deb&, lig&, w As Worksheet, i As Variant, h&
Application.ScreenUpdating = False
deb = 9 '1ère ligne de destination, modifiable
Rows(deb & ":" & Rows.Count).Delete 'RAZ
lig = deb
For Each w In Worksheets
    If w.Name <> Me.Name Then
        i = Application.Match("Commentaires", w.Columns(1), 0)
        If IsNumeric(i) Then
            h = w.UsedRange.Rows.Count - i + 1 'ligne de titre comptée
            If Application.CountA(w.Cells(i, 1).Resize(h)) > 1 Then
                Cells(lig, 1) = w.Cells(4, 1) 'titre
                Cells(lig, 1).Font.Bold = True 'en gras
                lig = lig + 2
                w.Cells(i + 1, 1).Resize(h - 1).Copy Cells(lig, 1)
                lig = lig + h
            End If
        End If
    End If
Next w
'---supprime les lignes vides excédentaires---
For lig = lig To deb + 1 Step -1
    If Cells(lig, 1) & Cells(lig - 1, 1) = "" Then Rows(lig).Delete
Next lig
End Sub

 

[Oliver77]

Du feu de dieu...
Merci, je continue à développer mon fichier.

Oliver77🙂