Recap sur X onglets

WDAndCo

WDAndCo

XLDnaute Impliqué
Bonjour le Forum

Je reviens vers vous car je bricole une recape automatique dont voici le code :
Code: 
Private Sub Worksheet_Activate()

    [A1:J1000].ClearContents                'Efface tout
    For I = Sheets.Count - 3 To 6 Step -1   'Tous les onglets de l'avant dernier au 5 eme
    nf = Sheets(I).Name                     'Nom de l'onglet
    With Sheets(I)
    
    derlig = .Range("AG" & Rows.Count).End(xlUp).Row 'Derniere ligne de l'onglet
    
    If .Range("AC" & derlig).Value = 0 Then derlig = derlig - 1 'Verifie que la derniere ligne correspond sinon -1
         
        ActiveSheet.Range("A" & I - 4).Value = nf
    
            If .Range("N" & derlig).Value <> "" And .Range("M" & derlig).Value <> "" And .Range("AA" & derlig).Value <> "" Then
    
        ActiveSheet.Range("B" & I - 4).Value = .Range("N" & derlig).Value
        ActiveSheet.Range("C" & I - 4).Value = .Range("O" & derlig).Value
        If .Range("AG" & derlig).Value = "C" Then ActiveSheet.Range("D" & I - 4).Value = .Range("AA" & derlig).Value
        If .Range("AG" & derlig).Value = "R" Then ActiveSheet.Range("E" & I - 4).Value = .Range("AA" & derlig).Value
        ActiveSheet.Range("F" & I - 4).Value = .Range("AF" & derlig).Value
        ActiveSheet.Range("G" & I - 4).Value = .Range("AG" & derlig).Value
        
            End If
    
    
    End With
    
        
Next I

    
End Sub
J'ai joint un fichier ou il y a des onglets dont un 'Je voudrais cela'

La Macro balais certaint onglets trouve la derniere ligne utile m'affiche les données sur l'onglet mais comment faire pour quelle remonte un nombre X de lignes pour m'afficher les données si les conditions sont remplies ou passe a l'onglet suivant.

C'est plus clair avec le fichier je pense !
D'avance merci.
 

Pièces jointes

  • HCR.xls
    466.5 KB · Affichages: 43
Trier par date Trier par votes
Dranreb

Dranreb

XLDnaute Barbatruc
Re : Recap sur X onglets

Bonsoir

Apparemment vos colonnes AG ne contient que du texte uniquement dans les lignes qui vous intéressent
Ne pourriez vous commencer par isoler ces ligne par :
VB: 
Set PlgLgn = .Columns("AG").SpecialCells(xlCellTypeConstants, 2).EntireRow
 
Vote positif 0 Vote négatif
WDAndCo

WDAndCo

XLDnaute Impliqué
Re : Recap sur X onglets

Bonjour Dranreb et le Forum

Merci pour cette solution mais la récupération doit être faite si AG <> "" et AC <> ""
De plus les cellules A sont fusionnés ! (c'est une adaptation)

D’avance merci
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Re : Recap sur X onglets

Bonjour.
Alors faites le tout simplement en deux fois :
VB: 
Set PlgLgn = .Columns("AG").SpecialCells(xlCellTypeConstants).EntireRow
Set PlgLgn = Intersect(.Columns("AC").SpecialCells(xlCellTypeConstants).EntireRow, PlgLgn)
 
Dernière édition:
Vote positif 0 Vote négatif
WDAndCo

WDAndCo

XLDnaute Impliqué
Re : Recap sur X onglets

Re bonjour Branreb et le Forum

Comment intégrer cela à la Macro qui ce déclenche lors du changement d’onglet :
Code: 
Private Sub Worksheet_Activate()

    [A1:J1000].ClearContents                'Efface tout
    For I = Sheets.Count - 3 To 6 Step -1   'Tous les onglets de l'avant dernier au 5 eme
    nf = Sheets(I).Name                     'Nom de l'onglet
    With Sheets(I)
    
    derlig = .Range("AG" & Rows.Count).End(xlUp).Row 'Derniere ligne de l'onglet
    
    If .Range("AC" & derlig).Value = 0 Then derlig = derlig - 1 'Verifie que la derniere ligne correspond sinon -1
         
        ActiveSheet.Range("A" & I - 4).Value = nf
    
            If .Range("N" & derlig).Value <> "" And .Range("M" & derlig).Value <> "" And .Range("AA" & derlig).Value <> "" Then
    
        ActiveSheet.Range("B" & I - 4).Value = .Range("N" & derlig).Value
        ActiveSheet.Range("C" & I - 4).Value = .Range("O" & derlig).Value
        If .Range("AG" & derlig).Value = "C" Then ActiveSheet.Range("D" & I - 4).Value = .Range("AA" & derlig).Value
        If .Range("AG" & derlig).Value = "R" Then ActiveSheet.Range("E" & I - 4).Value = .Range("AA" & derlig).Value
        ActiveSheet.Range("F" & I - 4).Value = .Range("AF" & derlig).Value
        ActiveSheet.Range("G" & I - 4).Value = .Range("AG" & derlig).Value
        
            End If
    
    
    End With
    
        
Next I

    
End Sub
D'avance merci.
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Re : Recap sur X onglets

Moi j'en récupérerais tout de suite les valeurs dans un petit tableau de variant et je ferais de même pour la sortie. Ce n'est jamais bon pour la rapidité du code de multiplier les utilisations de Range et Cells
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Re : Recap sur X onglets

Bonjour.

Il serait bon d'apprendre à le faire.
C'est quelque chose comme ça :
VB: 
Option Explicit

Private Sub Worksheet_Activate()
Dim Te(), Le As Long, Ts(1 To 10000, 1 To 7), Ls As Long, I As Long, NF As String, _
   F As Worksheet, PlgLgn As Range, A As Range
For I = 1 To Worksheets.Count
   Set F = Worksheets(I): NF = F.Name
   If Left$(NF, 1) = "S" Then
      F.Unprotect
      Set PlgLgn = F.Columns("AG").SpecialCells(xlCellTypeConstants).EntireRow
      Set PlgLgn = Intersect(F.Columns("AC").SpecialCells(xlCellTypeFormulas).EntireRow, PlgLgn)
      For Each A In PlgLgn.Areas
         Te = A.Resize(, 33).Value
         For Le = 1 To UBound(Te, 1)
            Ls = Ls + 1
            Ts(Ls, 1) = NF
            Ts(Ls, 2) = Te(Le, 14)
            Ts(Ls, 3) = Te(Le, 15)
            Ts(Ls, 4 - (Te(Le, 33) = "R")) = Te(Le, 29)
            Ts(Ls, 6) = Te(Le, 32)
            Ts(Ls, 7) = Te(Le, 33)
            Next Le, A: End If: Next I
Me.[A1:G1000].Value = Ts
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
WDAndCo

WDAndCo

XLDnaute Impliqué
Re : Recap sur X onglets

Bonjour Branreb et le Forum,

J'ai mis un certain temps pour comprendre qu'il ne valait pas d’autre onglet qui commençait par S

Comment faire pour ne pas prendre en compte la ligne Si AA=0 et mettre le numéro de semaine même si dans la plage copier il n'y a pas de valeur dans la colonne AA, histoire de vérifier que tous les onglets ont étaient parcouru.

D’avance merci.
Code: 
Option Explicit

Private Sub Worksheet_Activate()
[A2:J1000].ClearContents
Dim derlig
Dim Te(), Le As Long, Ts(1 To 10000, 1 To 7), Ls As Long, I As Long, NF As String, _
   F As Worksheet, PlgLgn As Range, A As Range
For I = 1 To Worksheets.Count
   Set F = Worksheets(I): NF = F.Name
   If Left$(NF, 1) = "S" Then
      F.Unprotect
      Set PlgLgn = F.Columns("AG").SpecialCells(xlCellTypeConstants).EntireRow
      Set PlgLgn = Intersect(F.Columns("AC").SpecialCells(xlCellTypeFormulas).EntireRow, PlgLgn)
      For Each A In PlgLgn.Areas
         Te = A.Resize(, 33).Value
         For Le = 1 To UBound(Te, 1)
            Ls = Ls + 1
            Ts(Ls, 1) = NF
            Ts(Ls, 2) = Te(Le, 14)
            Ts(Ls, 3) = Te(Le, 15)
            Ts(Ls, 4 - (Te(Le, 33) = "R")) = Te(Le, 29)
            Ts(Ls, 6) = Te(Le, 32)
            Ts(Ls, 7) = Te(Le, 33)
            Next Le, A: End If: Next I
Me.[A2:G2000].Value = Ts

derlig = Range("A" & Rows.Count).End(xlUp).Row

    Range("D" & derlig + 2).Select
    ActiveCell.FormulaR1C1 = "=SUM(D2:D" & derlig & ")"

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
WDAndCo

WDAndCo

XLDnaute Impliqué
Re : Recap sur X onglets

Bonjour Dranreble et leForum

J'ai enfin trouvé se que je voulais
Code: 
Option Explicit

Private Sub Worksheet_Activate()

[A3:J31000].ClearContents
Dim derlig
Dim DL, Te(), Le As Long, Ts(1 To 10000, 1 To 7), Ls As Long, I As Long, NF As String, _
   F As Worksheet, PlgLgn As Range, A As Range
For I = 1 To Worksheets.Count
   Set F = Worksheets(I): NF = F.Name
   If Left$(NF, 1) = "S" Then
      F.Unprotect
      'Set PlgLgn = F.Columns("AG").SpecialCells(xlCellTypeConstants).EntireRow
      Set PlgLgn = F.Columns("AG").SpecialCells(xlCellTypeFormulas).EntireRow
      Set PlgLgn = Intersect(F.Columns("AC").SpecialCells(xlCellTypeFormulas).EntireRow, PlgLgn)
      For Each A In PlgLgn.Areas
         Te = A.Resize(, 33).Value
         For Le = 1 To UBound(Te, 1)
            Ls = Ls + 1
            Ts(Ls, 1) = NF
            Ts(Ls, 2) = Te(Le, 14)
            Ts(Ls, 3) = Te(Le, 15)
            Ts(Ls, 4 - (Te(Le, 33) = "R")) = Te(Le, 29)
            Ts(Ls, 6) = Te(Le, 32)
            Ts(Ls, 7) = Te(Le, 33)
            Next Le, A: End If: Next I
Me.[A3:G1000].Value = Ts
'Application.Calculation = xlAutomatic
    derlig = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1").Value = derlig
    
        For DL = derlig To 3 Step -1 'Supprime les lignes inutilles
            If Range("D" & DL).Value = 0 And Range("E" & DL).Value = 0 Then Rows(DL).Delete
        Next DL
End Sub
Encore merci pour votre aide !
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Re : Recap sur X onglets

Bonjour.
Ben il vaudrait mieux ne pas les empiler dans Ts alors que de les supprimer à postériori !
Faites donc des test sur les bonnes colonnes de Te(Le, …) dans la boucle et n'effectuez le Ls = Ls + 1 suivi des mouvement de Te(Le, …) vers Ts(Ls, …) que si la ligne est significative !
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
206
aziz
A
B
  • Question
Microsoft 365 Additionner des cellules même ligne en userform vba
Réponses
13
Affichages
408
sousou
sousou
A
  • Résolu(e)
Microsoft 365 Correction du code vba
Réponses
5
Affichages
244
AD95
A
L
  • Résolu(e)
Microsoft 365 Suppression de cellules vide
Réponses
3
Affichages
215
Le Rouky
L
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
1 K
thivame
T
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
185
GClaire
G
F
  • Question
XL 2019 erreur 1004
Réponses
8
Affichages
272
florian50470
F
N
  • Question
XL 2021 Problème de logique => Erreur sur réponse if -- then
Réponses
2
Affichages
146
nano33320
N
halecs93
  • Question
Microsoft 365 Générer mail via Excel
Réponses
2
Affichages
305
halecs93
halecs93
M
  • Question
XL 2010 Calcul possible dans la zone de liste pour le débit et le crédit lors d'une recherche basée sur la zone de texte
Réponses
0
Affichages
449
Mody200
M

Membres actuellement en ligne

7 membres et 62 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 505
Messages
2 089 070
Membres
104 016
dernier inscrit
Mokson