Copies et suppressions sous conditions

F

fouggy

XLDnaute Junior
Bonjour à tous,

Et bien voilà, après avoir appliqué un certain nombre de traitements à mes fichiers, je bloque sur des commandes que je ne maîtrise pas.

Merci de votre aide pour atteindre mon objectif.

Si possible une macro (avec explication en vert) par Etape afin que je puisse analyser chaque commande et me l’approprier pour tendre vers l’autonomie.

Un grand merci par avance pour votre aide.

Soit un classeur ouvert comportant un nombre indéterminé d’onglets dont le premier s’appelle « Base » et sur lequel les actions des étapes 1,2 & 3 ne doivent pas s’appliquer.

Etape 1 : (Fichier Joint)
Soit la cellule A45 de tous les onglets, sauf celui appelé « Base », dont la configuration du contenu est toujours la même à savoir :
R+chiffre + Espace + Chaîne de caractères + Espace + (-) + Espace + Date au format jj/mm/aaaa
Ex : R1 ZZZ ZZZ ZZZZ – 01/01/2014
=> Supprime tous les onglets, sauf l’onglet « Base », dont la cellule A45 débute par autre chose que(ou différent de) « R1 » ; « R2 » ; « R3 » ou « R4 » en tenant compte du fait que parfois un espace ai pu se glisser avant le « R ».

Etape 2 : (Fichier Joint)
Dans la colonne B de tous les onglets, sauf l’onglet « Base », et pas toujours sur la même ligne, se trouve une série de cellules dont la première contient les caractères « N° » suivi d’un nombre variable de cellules débutant toutes par les caractères « R+chiffre » (Ex : R1 ou R2…)
=> Copie la date trouvée dans la cellule A45 dans les cellules de la colonne A lorsque celles-ci précèdent une cellule de la colonne B dont le contenu débute par « R+chiffre ».

Etape 3 : (Fichier Joint)
=> Supprime toutes les lignes dont les cellules de la colonne A ne débutent pas par une date.

Etape 4 : (Fichier Joint)
=> Copie les lignes restantes de chaque onglet dans l’onglet « Base » à la suite les unes des autres (en sautant une ligne si possible) et supprime chaque onglet à l’issue de cette copie.
 

Pièces jointes

  • Etape 1.xlsx
    10 KB · Affichages: 28
  • Etape 2.xlsx
    11.1 KB · Affichages: 33
  • Etape 1.xlsx
    10 KB · Affichages: 31
  • Etape 2.xlsx
    11.1 KB · Affichages: 35
  • Etape 1.xlsx
    10 KB · Affichages: 33
  • Etape 4.xlsx
    8.3 KB · Affichages: 24
  • Etape 3.xlsx
    10.9 KB · Affichages: 25
  • Etape 2.xlsx
    11.1 KB · Affichages: 26
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : Copies et suppressions sous conditions

Bonjour fouggy,

Code: 
Sub CopierSupprimerOnglets()
Dim lig&, w As Worksheet, t$, c As Range, i&
Application.ScreenUpdating = False 'fige l'écran
Application.DisplayAlerts = False 'pour les suppressions de feuille
'On Error Resume Next 'pour les Specialcells
lig = 1 '1ère ligne en feuille Base
For Each w In Worksheets
  If w.Name <> "Base" Then
    '---Etape 1---
    If Not Trim(Replace(w.[A45], Chr(160), "")) Like "R#*" Then GoTo 1
    '---Etape 2---
    t = Right(Trim(Replace(w.[A45], Chr(160), "")), 10)
    If IsDate(t) Then
      For Each c In w.[B:B].SpecialCells(xlCellTypeConstants, 2)
        If Trim(Replace(c, Chr(160), "")) Like "R#*" Then c(1, 0) = CDate(t)
      Next
    End If
    '---Etape 3---
    For i = w.UsedRange.Row + w.UsedRange.Rows.Count - 1 To 1 Step -1
      If Not IsDate(w.Cells(i, 1)) Then w.Rows(i).Delete
    Next
    '---Etape 4---
    w.UsedRange.Copy Sheets("Base").Cells(lig, 1)
    lig = lig + w.UsedRange.Rows.Count + 1
1   w.Delete
  End If
Next
End Sub
Vos explications sont très claires, sauf pour l'étape 3 :

Etape 3 : (Fichier Joint)
=> Supprime toutes les lignes dont les cellules de la colonne A ne débutent pas par une date
Cliquez pour agrandir...

Dans votre fichier ce ne peuvent être que des dates.

Ma macro supprime donc les lignes où il n'y a pas une date en colonne A.

Edit : j'ai inversé l'ordre de Trim et Replace.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copies et suppressions sous conditions

Re,

Avec la variable P, cette macro est plus rapide pour les modifications des étapes 2 et 3 :

Code: 
Sub CopierSupprimerOnglets()
Dim lig&, w As Worksheet, t$, P As Range, c As Range
Application.ScreenUpdating = False 'fige l'écran
Application.DisplayAlerts = False 'pour les suppressions de feuille
On Error Resume Next 'pour les Specialcells
lig = 1 '1ère ligne en feuille Base
For Each w In Worksheets
  If w.Name <> "Base" Then
    '---Etape 1---
    If Not Trim(Replace(w.[A45], Chr(160), "")) Like "R#*" Then GoTo 1
    '---Etape 2---
    t = Right(Trim(Replace(w.[A45], Chr(160), "")), 10)
    If IsDate(t) Then
      Set P = Nothing
      For Each c In w.[B:B].SpecialCells(xlCellTypeConstants, 2)
        If Trim(Replace(c, Chr(160), "")) Like "R#*" Then _
          Set P = Union(c(1, 0), IIf(P Is Nothing, c(1, 0), P))
      Next
      If Not P Is Nothing Then P = CDate(t)
    End If
    '---Etape 3---
    Set P = Nothing
    For Each c In w.UsedRange.EntireRow.Columns(1).Cells
      If Not IsDate(c) Then Set P = Union(c, IIf(P Is Nothing, c, P))
    Next
    If Not P Is Nothing Then P.EntireRow.Delete
    '---Etape 4---
    w.UsedRange.Copy Sheets("Base").Cells(lig, 1)
    lig = lig + w.UsedRange.Rows.Count + 1
1   w.Delete
  End If
Next
End Sub
Edit : j'ai inversé l'ordre de Trim et Replace.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copies et suppressions sous conditions

Re,

Pour peaufiner, j'ai ajouté un test à la fin au cas où la feuille à copier ne contient plus rien :

Code: 
Sub CopierSupprimerOnglets()
Dim lig&, w As Worksheet, t$, P As Range, c As Range
Application.ScreenUpdating = False 'fige l'écran
Application.DisplayAlerts = False 'pour les suppressions de feuille
On Error Resume Next 'pour les Specialcells
lig = 1 '1ère ligne en feuille Base
For Each w In Worksheets
  If w.Name <> "Base" Then
    '---Etape 1---
    If Not Trim(Replace(w.[A45], Chr(160), "")) Like "R#*" Then GoTo 1
    '---Etape 2---
    t = Right(Trim(Replace(w.[A45], Chr(160), "")), 10)
    If IsDate(t) Then
      Set P = Nothing
      For Each c In w.[B:B].SpecialCells(xlCellTypeConstants, 2)
        If Trim(Replace(c, Chr(160), "")) Like "R#*" Then _
          Set P = Union(c(1, 0), IIf(P Is Nothing, c(1, 0), P))
      Next
      If Not P Is Nothing Then P = CDate(t)
    End If
    '---Etape 3---
    Set P = Nothing
    For Each c In w.UsedRange.EntireRow.Columns(1).Cells
      If Not IsDate(c) Then Set P = Union(c, IIf(P Is Nothing, c, P))
    Next
    If Not P Is Nothing Then P.EntireRow.Delete
    '---Etape 4---
    If Application.CountA(w.UsedRange) = 0 Then GoTo 1
    w.UsedRange.Copy Sheets("Base").Cells(lig, 1)
    lig = lig + w.UsedRange.Rows.Count + 1
1   w.Delete
  End If
Next
End Sub
A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copies et suppressions sous conditions

Bonjour fouggy, le forum,

Toujours pour peaufiner j'ai ajouté un tri des dates à la fin :

Code: 
Sub CopierSupprimerOnglets()
Dim F As Worksheet, ligdeb&, lig&, w As Worksheet, t$, P As Range, c As Range
Application.ScreenUpdating = False 'fige l'écran
Application.DisplayAlerts = False 'pour les suppressions de feuille
On Error Resume Next 'pour les SpecialCells
Set F = Sheets("Base") 'feuille de restitution
ligdeb = 1 '1ère ligne en feuille Base
lig = ligdeb
For Each w In Worksheets
  If w.Name <> F.Name Then
    '---Etape 1---
    If Not Trim(Replace(w.[A45], Chr(160), "")) Like "R#*" Then GoTo 1
    '---Etape 2---
    t = Right(Trim(Replace(w.[A45], Chr(160), "")), 10)
    If IsDate(t) Then
      Set P = Nothing
      For Each c In w.[B:B].SpecialCells(xlCellTypeConstants, 2)
        If Trim(Replace(c, Chr(160), "")) Like "R#*" Then _
          Set P = Union(c(1, 0), IIf(P Is Nothing, c(1, 0), P))
      Next
      If Not P Is Nothing Then P = CDate(t)
    End If
    '---Etape 3---
    Set P = Nothing
    For Each c In w.UsedRange.EntireRow.Columns(1).Cells
      If Not IsDate(c) Then Set P = Union(c, IIf(P Is Nothing, c, P))
    Next
    If Not P Is Nothing Then P.EntireRow.Delete
    '---Etape 4---
    w.UsedRange.Copy F.Cells(lig, 1)
    lig = lig + w.UsedRange.Rows.Count
1   w.Delete
  End If
Next
'---Tri des dates et insertion de lignes---
With Intersect(F.Rows(ligdeb & ":" & F.Rows.Count), F.UsedRange)
  .Sort .Columns(1), xlAscending, Header:=xlNo
  For lig = .Rows.Count To 1 Step -1
    If Not IsDate(.Cells(lig, 1)) Then .Rows(lig).Delete xlUp Else _
    If .Cells(lig, 1) <> .Cells(lig + 1, 1) Then .Rows(lig + 1).Insert xlDown
  Next
End With
End Sub
Si l'on veut un tri décroissant remplacer xlAscending par xlDescending.

Edit : je joins le fichier.

A+
 

Pièces jointes

  • Copier Supprimer Onglets(1).xlsm
    26.8 KB · Affichages: 23
Dernière édition:
Vote positif 0 Vote négatif
F

fouggy

XLDnaute Junior
Re : Copies et suppressions sous conditions

Pfffffffffffffffffffffffffffffffffffooooooooooooooooooouuuuuuuuuuuuuuuuuuuuuuuuuuu

Parfaitement énorme ce que tu arrives à faire et en si peu de temps...

Va me falloir un nombre incalculable d'années pour arriver à sortir de telles macros. Mais bon même si je comprends pas tout, tout de suite, j'ai la volonté d'y arriver, lol.

En tous les cas un merci aussi énorme que ta contribution...

Du coup est-ce que tu te sentirais une autre macro dont les commandes sont quelque peu similaires ?

Cordialement.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copies et suppressions sous conditions

Re,

Je viens de faire une petite modif en fin de macro du post #5 pour que le "nettoyage" des lignes de la feuille "Base" se fasse jusqu'à la 1ère ligne, tenez en compte.

fouggy à dit:
Du coup est-ce que tu te sentirais une autre macro dont les commandes sont quelque peu similaires ?
Cliquez pour agrandir...

Si ce n'est pas trop tordu nous sommes tous là pour ça.

A+
 
Vote positif 0 Vote négatif
F

fouggy

XLDnaute Junior
Re : Copies et suppressions sous conditions

T'es parfaitement génial, lol

Ci-dessous la procédure étape par étape. S'il est possible d'avoir un commentaire pour chaque commande afin que j'arrive à comprendre et à, éventuellement, comparer avec ta macro précédente, ce serait le top du top.

En revanche, j'ai créer plusieurs "micro fichiers" pour bien décomposer les étapes avec des codes couleur. Ils sont au nombre de 11 et vais devoir les envoyer en plusieurs fois.

LA PROCEDURE :

Traitement à appliquer à tous les onglets sauf au premier nommé : « Base », dans un classeur ouvert avec un nombre indéterminé d’onglets ayant tous la même configuration.

Dans la colonne C, et quel que soit le nombre de cellules non vides et variable, recherche dans chaque cellule les nombres dont la valeur est comprise entre 10.0 et 19.9

Etape 1
Si sur l'ensemble de cette série (de nombres contenus dans chaque cellule de la colonne C) on ne comptabilise qu'UN SEUL nombre compris entre 10.0 et 19.9 :
* Coller le caractère « * » dans la cellule D2 (Ex. en bleu)
* Copier le nombre contenu dans la cellule de la colonne B jouxtant la cellule de la colonne C, sur la même ligne, pour la coller dans la cellule E2 (Ex. en vert)

Etape 2
Si sur l'ensemble de cette série on ne comptabilise AUCUN nombre compris entre 10.0 et 19.9 coller la valeur (N) dans la cellule D2
Si sur l'ensemble de cette série on comptabilise PLUS DE UN nombre compris entre 10.0 et 19.9 coller la valeur (N) dans la cellule D2

Etape 3
Dans la cellule B2 : * Récupérer l'heure au format hh/mm pour la copier dans la cellule C2

Etape 4
Dans la cellule B2 : * Supprimer tous les caractères différents du code : « Rx Cx »
Supprimer Espace avant le code « Rx Cx » s’il en existe

Etape 5
Dans la cellule B1 : * Récupérer la date au format jj/mm/aaaa pour la copier dans la cellule A2

Etape 6
Dans tous les onglets, supprimer toutes les lignes pour ne conserver que la ligne 2

Etape 7
Considérant le fichier d’origine contenant le premier onglet « Base » :
Copie à la suite dans l’onglet « Base », la ligne 1 de tous les autres onglets avant de les supprimer tous définitivement.

Et voilà....

Dans l'attente de te relire....

Cordialement.
 

Pièces jointes

  • Etape 2.xlsx
    10.9 KB · Affichages: 29
  • Etape 1.xlsx
    9.6 KB · Affichages: 24
  • Etape 2.xlsx
    10.9 KB · Affichages: 29
  • Etape 1.xlsx
    9.6 KB · Affichages: 27
  • Etape 3 2.xlsx
    11.3 KB · Affichages: 24
  • Etape 3 1.xlsx
    9.7 KB · Affichages: 25
  • Etape 2.xlsx
    10.9 KB · Affichages: 25
  • Etape 1.xlsx
    9.6 KB · Affichages: 24
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copies et suppressions sous conditions

Re,

Un peu tordu quand même...

Et j'aurai préféré un fichier avec l'onglet "Base" et plusieurs onglets différents.

Voyez ce fichier (2) et cette nouvelle macro :

Code: 
Sub CopierSupprimerOnglets()
Dim F As Worksheet, ligdeb&, lig&, w As Worksheet, t$, n&, c As Range
Application.ScreenUpdating = False 'fige l'écran
Application.DisplayAlerts = False 'pour les suppressions de feuille
Set F = Sheets("Base") 'feuille de restitution
ligdeb = 1 '1ère ligne en feuille Base
lig = ligdeb
For Each w In Worksheets
  If w.Name <> F.Name Then
    '---Etapes 1 et 2 étude colonne C---
    w.[C:C].NumberFormat = "General" 'sécurité
    w.[C:C].Replace Chr(160), "", xlPart
    w.[C:C].Replace " ", ""
    w.[C:C].Replace ".", "." 'pour obtenir des valeurs numériques
    n = Application.CountIf(w.[C:C], ">=10") - Application.CountIf(w.[C:C], ">19.9")
    If n = 1 Then
      w.[D2] = "*"
      For Each c In w.[C:C].SpecialCells(xlCellTypeConstants, 1)
        If c >= 10 And c <= 19.9 Then w.[E2] = c(1, 0): Exit For
      Next
    Else
      w.[D2] = "N"
    End If
    '---Etape 3 heure---
    t = Replace(Right(Trim(Replace(LCase(w.[B2]), Chr(160), "")), 5), "h", ":")
    If IsDate(t) Then w.[C2] = CDate(t)
    w.[C2].NumberFormat = "hh:mm"
    '---Etape 4 R C---
    t = Trim(Replace(w.[B2], Chr(160), " "))
    If t Like "R# C#*" Then w.[B2] = Left(t, 5)
    '---Etape 5 date---
    t = Right(Trim(Replace(w.[B1], Chr(160), "")), 10)
    If IsDate(t) Then w.[A2] = CDate(t)
    w.[A2].NumberFormat = "dd/mm/yyyy"
    '---Etape 6 inutile---
    '---Etape 7---
    w.Rows(2).Copy F.Cells(lig, 1)
    lig = lig + 1
    w.Delete
  End If
Next
'---Tri des dates---
With Intersect(F.Rows(ligdeb & ":" & F.Rows.Count), F.UsedRange)
  .Sort .Columns(1), xlAscending, Header:=xlNo
End With
End Sub
A+
 

Pièces jointes

  • Copier Supprimer Onglets(2).xlsm
    30.8 KB · Affichages: 19
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copies et suppressions sous conditions

Bonjour fouggy, le forum,

Dans cette version (2 bis) j'ai ajouté les heures en 2ème clé du tri.

A+
 

Pièces jointes

  • Copier Supprimer Onglets(2 bis).xlsm
    30.1 KB · Affichages: 24
Vote positif 0 Vote négatif
F

fouggy

XLDnaute Junior
Re : Copies et suppressions sous conditions

Slt Job75,

Ai pris le temps de tester ta dernière macro avant de répondre. C'est parfaitement impressionnant...

Pour l'onglet "Base" manquant, j'ai oublié de le signaler, c'est vrai mais l'esprit était tellement proche de la 1re problématique posée... (pareil pour les onglets) et puis c'est vrai aussi qu'à force de vouloir entrer dans les détails (avec codes couleurs) pour exposer le plus clairement la demande on en oubli parfois les principes de bases à reposer tout le temps de la manière la plus claire dans un souci de compréhension de l'autre. Mais on pêche parfois aussi dans le cahier des charges, parce qu'il faut parfois attraper l'idée avant qu'elle ne vous échappe et la développer par écrit pour s'en souvenir, la tester, se donner les moyens d'aller plus loin...

Un grand grand merci à toi et à bientôt j'espère pour développer sur d'autres problématiques que celui annoncé dans le présent post.

Très Cordialement.
 
Vote positif 0 Vote négatif

Discussions similaires

A
  • Résolu(e)
Microsoft 365 Correction d'un code vba
2
Réponses
22
Affichages
793
AD95
A
kaki31
  • Question
XL 2016 Exporter vers une autre feuille sous conditions
Réponses
4
Affichages
301
kaki31
kaki31
A
  • Résolu(e)
Microsoft 365 Copier la même cellule de plusieurs onglets dans différentes colonnes
2
Réponses
23
Affichages
849
AlexiaC
A
S
  • Question
Autres Macro sous conditions
Réponses
3
Affichages
280
scorpileo
S
Z
  • Question
Microsoft 365 Mise en forme de tableau et répétition de formule
Réponses
2
Affichages
209
DJunqueira
D
M
  • Question
Microsoft 365 Recherche multicritères et résultat sous forme de croix (si possible via formule SI et ET)
Réponses
4
Affichages
251
danielco
D
xUpsilon
  • Résolu(e)
XL 2019 Traduire un array de bytes en string
2
Réponses
22
Affichages
661
dysorthographie
dysorthographie
X
  • Question
XL 2016 Copier à partir de la dernière ligne renseignée.
Réponses
8
Affichages
427
Xender
X
B
  • Question
Microsoft 365 [RESOLU] Supprimer Ligne rapidement et avec plusieurs conditions
Réponses
5
Affichages
129
BENAM69
B
M
  • Résolu(e)
Microsoft 365 Si avec des conditions
Réponses
8
Affichages
455
milor17
M

Membres actuellement en ligne

11 membres et 115 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 331
Messages
2 087 360
Membres
103 529
dernier inscrit
moket07