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

Oliver77

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

Pièces jointes

  • MonFichier.xls
    87 KB · Affichages: 9
  • RésultatSouhaité.xls
    85 KB · Affichages: 5

Oliver77

XLDnaute Occasionnel
;)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...:p
 

job75

XLDnaute Barbatruc
Bonjour Oliver77, le forum,

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

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

Pièces jointes

  • MonFichier(1).xls
    79 KB · Affichages: 10
Dernière édition:

Oliver77

XLDnaute Occasionnel
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é...:oops:
Comment faire pour éviter les feuilles sans commentaires ?

Merci d'avance,
Oliver77
 

Pièces jointes

  • MonFichier(v2).xls
    122 KB · Affichages: 5

job75

XLDnaute Barbatruc
Comment faire pour éviter les feuilles sans commentaires ?
Il suffit de décaler les 3 lignes de code du titre, fichier (2) :
VB:
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.
 

Pièces jointes

  • MonFichier(2).xls
    112 KB · Affichages: 7

Oliver77

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

XLDnaute Occasionnel
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.:D:D:D
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

XLDnaute Barbatruc
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) :
VB:
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
 

Pièces jointes

  • MonFichier(3).xls
    126.5 KB · Affichages: 8

Discussions similaires

Statistiques des forums

Discussions
311 741
Messages
2 082 055
Membres
101 882
dernier inscrit
XaK_