Consolidation de données

[Merlin258413]

Bonjour à tous
J'ai un fichier excel ci joint je désire consolider dans l'onglet "CONSO" toutes les données des onglets en jaune et donc exclure les autres comme paramètre.
J'ai ce code mais il doit me manque la partie exclusion pouvez vous m'aider svp ?
En vous remerciant par avance et excellente journée

Sub Consolide()
Dim NbLg As Long
Dim Ws As Worksheet

  With Sheets("CONSO")
    If .Range("A2") <> "" Then
      .Range("A2:AG" & .Range("A" & Rows.Count).End(xlUp).Row).ClearContents
    End If
    For Each Ws In Sheets
      Select Case Ws.Name
        Case "CONSO"
        Case Else
          If Ws.Range("A2") <> "" Then
            NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
            Ws.Range("A2:AG" & NbLg).Copy _
                  Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
          End If
      End Select
    Next Ws
  End With
 
End Sub

 

[eriiic]

Bonjour,

avec 0 données la consolidation est vite faite
Pourquoi par macro, 'Données / Outils de données / Consolider' ne fonctionne pas ?

eric

 

[Merlin258413]

Bonjour je pensais que la trame du fichier et mon code suffisaient.
Je passe par macro car je ne sais pas utiliser l'outil de données consolider je vais essayer de m'y pencher si je peux consolider plusieurs onglets
merci

 

[zebanx]

Bonjour à tous

@Merlin258413
Pour l'exclusion, sans avoir testé le code, pensez à quelque chose comme

Dans votre code : If Ws.Range("A2") <> "" Then
à remplacer par : If Ws.Range("A2") <> "" and Ws.Tab.Color = vbYellow Then

Un exemple joint utilisant cette instruction.
Bonne finalisation.

@+

 

[Merlin258413]

Bonjour merci cela fonctionne pourrait on faire cela avec les noms des feuilles
En vous remerciant

 

[zebanx]

Re,

Un essai. Ma version excel ne comporte pas les segments, j'ai désactivé la fin du code.
La macro a lancé s'appelle "consolide2" (dans le module 2) avec les noms de feuilles AK1, AK2, AK3 modifiables dans l'array.

@+

Sub Consolide2()
Dim NbLg As Long
Dim Ws As Worksheet

A = Array("AK1", "AK2", "AK3")

  With Sheets("CONSO")
    If .Range("A2") <> "" Then
      .Range("A2:AG" & .Range("A" & Rows.Count).End(xlUp).Row).ClearContents
    End If
    For Each Ws In Sheets
      Select Case Ws.Name
        Case "CONSO"
        Case Else
          For n = LBound(A) To UBound(A)
            If Ws.Range("A2") <> "" And Ws.Name = A(n) Then
            NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
            Ws.Range("A2:AG" & NbLg).Copy _
                  Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
         Next n
      End Select
    Next Ws
  End With
  End sub

 

[Merlin258413]

Bonjour je vous remercie pour votre réponse, je la teste et je reviens vers vous
Encore un grand merci