Microsoft 365 Créer un synthèse de plusieurs onglets

[cdric78]

Bonjour,
Je fais appel à vous pour m'aider à réaliser quelques choses que je n'arrive pas à faire.
Je souhaite faire une synthèse de plusieurs onglets dans un seul onglet.

Je possède plusieurs onglets (CARR. 1, CARR.2, CARR. 3) mais ce nombre d'onglet sera évolutif (et le nommage des onglets ne conservera pas la structure "CARR. ?").
Je souhaite que l'onglet "Synthèse" reprenne les valeurs A1 et les valeurs présentes dans la colonne C si il y a un "1" en D sur la même ligne. Par exemple l'onglet synthèse ne devra pas affiché le contenu C10 de l'onglet CARR. 1 car il n'y a pas de 1 en D10.

Dans mon exemple, l'onglet "Synthèse" affiche le résultat attendu.

Je vous remercie par avance pour votre aide.

 

[fanfan38]

Bonjour
Ci joint ma solution par macro
(elle se lance quand tu changes de feuille et que tu es sur la feuille synthese)

A+ François

 

[cdric78]

Merci beaucoup !!! C'est top!

 

[cdric78]

Bonjour,

Merci à FANFAN38 pour cette macro.

Je souhaite savoir comment faire pour modifier la macro afin de conserver la mise en forme des cellules copiés (police, mise en forme, lien hypertexte etc...)

Merci par avance pour vos réponses.

Private Sub Worksheet_Activate()
  Dim i As Integer, j As Long, lig As Long
 ' Set sh = Sheets("Synthèse")
  Range("A2:B1000").ClearContents
  lig = Range("B" & Rows.Count).End(xlUp).Row + 1
  For i = 1 To Sheets.Count
    If Sheets(i).Name <> "Synthèse" Then
      Range("A" & lig) = Sheets(i).Range("A1")
      For j = 2 To Sheets(i).Range("D" & Rows.Count).End(xlUp).Row
        If Sheets(i).Range("D" & j) = 1 Then
          Range("B" & lig) = Sheets(i).Range("C" & j)
          lig = lig + 1
        End If
      Next
      lig = lig + 2
    End If
  Next
End Sub

 

[job75]

Bonjour cdric78, François,

Les instruction comme :

Range(x) = Sheets(i).Range(y)

copient uniquement les valeurs.

Pour copier aussi les formats utilisez :

Sheets(i).Range(y).Copy Range(x)

A+

 

[cdric78]

Merci @job75,

Quand j'essai de modifier la macro avec tes indications, je rencontre un messages d'erreur:
"Erreur de compilation: Attendu: Fin d'instruction"

​

 

[job75]

Vous n'avez donc pas appliqué correctement mes instructions pour obtenir :

Private Sub Worksheet_Activate()
  Dim i As Integer, j As Long, lig As Long
 ' Set sh = Sheets("Synthèse")
  Range("A2:B1000").ClearContents
  lig = Range("B" & Rows.Count).End(xlUp).Row + 1
  For i = 1 To Sheets.Count
    If Sheets(i).Name <> "Synthèse" Then
      Sheets(i).Range("A1").Copy Range("A" & lig)
      For j = 2 To Sheets(i).Range("D" & Rows.Count).End(xlUp).Row
        If Sheets(i).Range("D" & j) = 1 Then
          Sheets(i).Range("C" & j).Copy Range("B" & lig)
          lig = lig + 1
        End If
      Next
      lig = lig + 2
    End If
  Next
End Sub

 

[cdric78]

Merci Job75,

Désolé, je suis novice en VBA, mais là ça me semble plus clair. J'ai identifié là j'avais réalisé une erreur.

Bonne soirée