Sujet Précédent Sujet Suivant

Déplacer / décaler des plages, condition, boucle ?

gondrule1 Messages postés 33 Date d'inscription lundi 29 septembre 2008 Statut Membre Dernière intervention 29 février 2012 - 26 déc. 2011 à 14:31
gondrule1 Messages postés 33 Date d'inscription lundi 29 septembre 2008 Statut Membre Dernière intervention 29 février 2012 - 27 déc. 2011 à 11:44
Bonjour à tous,

Je viens faire appel à vos lumières parce que là, décidément, je n'y arriverai pas tout seul. Je vais essayer d'être clair pour une fois , mais je vous conseillerai quand même d'ouvrir le fichier joint (Tableauexemple,sans macro dedans)
J'ai un tableau avec 10 colonnes dont certaines peuvent être vides :
La 1ère colonne n'est jamais vide et contient toujours quelque chose en ligne 2 (Toto)
Toutes les autres colonnes peuvent, selon le cas, être vides mais il y a toujours au moins deux colonnes remplies après la 1ère colonne, et au maximum (comme dans le fichier joint) 9.
(On peut considérer les colonnes contenant les verbes comme des colonnes maîtresses puisque ce sont d'elles dont dépendent la construction du tableau)
En fonction du verbe (toujours les trois mêmes) contenu dans une colonne, je dois créer un en-tête nommée par ce verbe, et déplacer les éléments qui en dépendent, sous cet en-tête, en commençant une cellule en-dessous par rapport à Toto (en ligne 3, mais pour le 1er verbe uniquement, pour les autres verbes de colonne, je voudrais que soit créée un décalage par rapport au contenu du verbe précédent ?)
Il y a un cas particulier pour le verbe "dort", où je dois récupérer 2 valeurs et non pas une.
Je suis donc obligé de rajouter deux colonnes (si les 2 autres verbes sont présents et occupent respectivement les colonnes C et D, et pour ne pas effacer les données des colonnes suivantes)
Un des premiers problèmes est que si le verbe « dort » n'est pas présent dans la 1ère colonne « maîtresse » ma macro s'arrête, puiqu'elle ne trouve plus de verbe, dans la colonne qui tient compte du rajout de colonne qui n'a pas eu lieu?
Comment dire en VBA : Si « dort » n'est pas présent dans la 1ère colonne maîtresse, il faut chercher dans la colonne -2 ?
De manière générale, je suis ouvert à toutes vos propositions qui me permettraient de réduire un peu mon usine à gaz qui ne prend pas en compte tous les cas de figure possible?.
Bonnes fêtes de fin d'année !!
Voici le code de ma macro :
Sub countoccurences()
'
' countoccurences Macro
Dim x As Long, y As Long, z As Long
Dim u As Long, v As Long, w As Long
Dim Toto As Range
Dim c As Range
Dim d As Range
Dim rngRed As Range


    Set Toto = Range("A2")
    MsgBox Toto
  x = Application.WorksheetFunction.CountIf(Range("C:C"), "mange")
y = Application.WorksheetFunction.CountIf(Range("C:C"), "boit")
z = Application.WorksheetFunction.CountIf(Range("C:C"), "dort")

If x > 0 Then
Range("C1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "Mange1"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(x).Insert xlShiftDown

For Each c In ActiveSheet.Range("C:C")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
  
  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      x = 0
MsgBox x


If x 0 And y > 0 And IsEmpty(Range("C1").Value) False Then
Range("D1").Select
numColumns = numColumns + 1
ActiveCell.Value = "boit1"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(y).Insert xlShiftDown
For Each c In ActiveSheet.Range("C:C")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("D1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      y = 0


If z > 0 Then
Range("D1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
ActiveCell.EntireColumn.Offset(0, 1).Insert
numColumns = numColumns + 1
Range("E1").Select
ActiveCell.Value = "dort1"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(z).Insert xlShiftDown
For Each c In ActiveSheet.Range("C:C")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("E1").Offset(NumRows + 1, 0)
Selection.ClearContents
 rngRed.Offset(0, 1).Activate
 Selection.Copy
ActiveSheet.Paste Destination:=Range("F1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      z = 0
      
    u = Application.WorksheetFunction.CountIf(Range("H:H"), "mange")
      If u > 0 Then
Range("G1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange2"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(u).Insert xlShiftDown

For Each c In ActiveSheet.Range("H:H")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
  
  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("G1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      u = 0
      
          v = Application.WorksheetFunction.CountIf(Range("H:H"), "boit")
      If v > 0 Then
Range("H1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit2"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(v).Insert xlShiftDown

For Each c In ActiveSheet.Range("H:H")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
  
  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("H1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      v = 0
      
     w = Application.WorksheetFunction.CountIf(Range("H:H"), "dort")
      

If w > 0 Then
Range("H1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert

numColumns = numColumns + 1
Range("I1").Select
ActiveCell.Value = "dort2"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(w).Insert xlShiftDown
For Each c In ActiveSheet.Range("H:H")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("I1").Offset(NumRows + 1, 0)
Selection.ClearContents
 rngRed.Offset(0, 2).Activate
 Selection.Copy
ActiveSheet.Paste Destination:=Range("J1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      w = 0
      
      
      

End Sub

3 réponses

Réponse 1 / 3
cs_Jack Messages postés 14006 Date d'inscription samedi 29 décembre 2001 Statut Modérateur Dernière intervention 28 août 2015 79
26 déc. 2011 à 15:43
Salut

Problème expliqué mais trop complexe.
Je ne ferai que répondre à ta question :
"Comment dire en VBA : Si « dort » n'est pas présent dans la 1ère colonne maîtresse, il faut chercher dans la colonne -2 ?"
Il suffit de faire une recherche parmi les deux colonnes en lui disant de faire cette recherche par colonne, au lieu de "par ligne" par défaut.
Exemple : 
    Dim oColonnes As Range
    Dim oRange As Range
    Set oColonnes = Range("A:B")
    Set oRange = oColonnes.Find(What:="dort", _
                                LookIn:=xlFormulas, _
                                SearchOrder:=xlByColumns, _
                                MatchCase:=False)
    If oRange Is Nothing Then
        MsgBox """Dort"" non trouvé"
    Else
        MsgBox """Dort"" trouvé en cellule " & oRange.Address
    End If

Vala
Jack, MVP VB
NB : Je ne répondrai pas aux messages privés

Le savoir est la seule matière qui s'accroit quand on la partage (Socrate)
0
Réponse 2 / 3
gondrule1 Messages postés 33 Date d'inscription lundi 29 septembre 2008 Statut Membre Dernière intervention 29 février 2012
26 déc. 2011 à 17:53
Salut Jack,

Je vois que tu as un avatar de circonstance
Je vais étudier ton code pour voir comment je peux l'intégrer dans mon usine (mais au département contrôle/qualité )

En attendant, j'ai quand même un peu progressé (j'arrive à créer le décalage dont j'avais besoin, même s'il est inversé),je commence à la colonne B (ce que j'aurais dû faire depuis le début...) même si je bloque sur un nouveau problème ....
Pour tester l'existence de "bois" et "mange" dans la 1ère colonne maîtresse, j'ai introduit de nouvelles variables a, b 
a = x
MsgBox a
If a = 0 Then GoTo Miss


Comme ça si x = 0, je l'envoie traiter le prochain verbe et j'utilise la colonne qu'aurait dû utiliser x...
Ca fonctionne, jusqu'à ce que je veuille tester la condition si 2 verbes n'existent pas :
b = y

If a 0 And b 0 Then GoTo RepseulC

If b = 0 Then GoTo Rep


A chaque fois, ça ne prend pas en compte le 1er GoTo, il va au 2ème alors que RepseulC fonctionne quand je le transforme en Macro.
Aurais-tu une idée ?
Encore merci pour le code et bonne soirée ! 

Sub countoccurencestesta()
'
' countoccurences Macro
Dim x As Long, y As Long, z As Long
Dim u As Long, v As Long, w As Long
Dim a As Long, b As Long, i As Long, j As Long
Dim Toto As Range
Dim c As Range
Dim d As Range
Dim rngRed As Range


    Set Toto = Range("A2")
    MsgBox Toto
  x = Application.WorksheetFunction.CountIf(Range("C:C"), "mange")
y = Application.WorksheetFunction.CountIf(Range("C:C"), "boit")
z = Application.WorksheetFunction.CountIf(Range("C:C"), "dort")
a = x
MsgBox a
If a = 0 Then GoTo Miss

If x > 0 Then
Range("B1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange1"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(x).Insert xlShiftDown

For Each c In ActiveSheet.Range("C:C")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
  
  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("B1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      x = 0
MsgBox x
MsgBox a
b = y

If a 0 And b 0 Then GoTo RepseulC

If b = 0 Then GoTo Rep

If y > 0 Then
Range("C1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit1"
Toto.Offset(1, 0).Activate
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(y).Insert xlShiftDown
For Each c In ActiveSheet.Range("C:C")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      y = 0


If z > 0 Then
Range("D1").Activate
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.EntireColumn.Offset(0, 1).Insert
numColumns = numColumns + 1
Range("D1").Activate
ActiveCell.Value = "dort1"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(z).Insert xlShiftDown
For Each c In ActiveSheet.Range("C:C")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("D1").Offset(NumRows + 1, 0)
Selection.ClearContents
 rngRed.Offset(0, 1).Activate
 Selection.Copy
ActiveSheet.Paste Destination:=Range("E1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      z = 0
      
    u = Application.WorksheetFunction.CountIf(Range("G:G"), "mange")
      If u > 0 Then
Range("F1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange2"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(u).Insert xlShiftDown

For Each c In ActiveSheet.Range("G:G")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
  
  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("F1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      u = 0
      
          v = Application.WorksheetFunction.CountIf(Range("G:G"), "boit")
      If v > 0 Then
Range("G1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit2"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(v).Insert xlShiftDown

For Each c In ActiveSheet.Range("G:G")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
  
  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("G1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      v = 0
      
     w = Application.WorksheetFunction.CountIf(Range("G:G"), "dort")
      

If w > 0 Then
Range("H1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("H1").Select
ActiveCell.Value = "dort2"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(w).Insert xlShiftDown
For Each c In ActiveSheet.Range("G:G")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("H1").Offset(NumRows + 1, 0)
Selection.ClearContents
 rngRed.Offset(0, 1).Activate
 Selection.Copy
ActiveSheet.Paste Destination:=Range("I1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      w = 0
      
Miss:
b = y
MsgBox b
If y > 0 Then
Range("B1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit1"
Toto.Offset(1, 0).Activate
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(y).Insert xlShiftDown
For Each c In ActiveSheet.Range("C:C")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("B1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      y = 0
      
     If z > 0 Then
Range("C1").Activate
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
numColumns = numColumns + 1
Range("C1").Activate
ActiveCell.Value = "dort1"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(z).Insert xlShiftDown
For Each c In ActiveSheet.Range("C:C")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
 rngRed.Offset(0, 1).Activate
 Selection.Copy
ActiveSheet.Paste Destination:=Range("D1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      z = 0
      
      
RepseulC:
  If z > 0 Then
Range("B1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count

ActiveCell.Value = "dort1"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(z).Insert xlShiftDown
For Each c In ActiveSheet.Range("C:C")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("B1").Offset(NumRows + 1, 0)
Selection.ClearContents
 rngRed.Offset(0, 1).Activate
 Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      z = 0
      
Rep:
  If z > 0 Then
Range("C1").Activate
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
numColumns = numColumns + 1
Range("C1").Activate
ActiveCell.Value = "dort1"
Toto.Offset(1, 0).Select
MsgBox ActiveCell.Address
ActiveCell.EntireRow.Resize(z).Insert xlShiftDown
For Each c In ActiveSheet.Range("C:C")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c

  rngRed.Offset(0, -1).Activate
   
   Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
 rngRed.Offset(0, 1).Activate
 Selection.Copy
ActiveSheet.Paste Destination:=Range("D1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If

    Next c
      End If
      z = 0
      


End Sub
0
Réponse 3 / 3
gondrule1 Messages postés 33 Date d'inscription lundi 29 septembre 2008 Statut Membre Dernière intervention 29 février 2012
27 déc. 2011 à 11:44
Salut,

Finalement, j'y suis arrivé... Il faut que je teste encore, mais j'ai l'impression que j'ai réussi à déclarer toutes les combinaisons possibles ... Il y a certainement plus simple mais ... Alors voilà :
Sub countoccurencestestb()
'
' countoccurences Macro
Dim x As Long, y As Long, z As Long, u As Long, v As Long, w As Long, n As Long, o As Long, p As Long, a As Long, b As Long, i As Long, j As Long
Dim Toto As Range, c As Range, rngRed As Range
Dim iCol As Integer

Set Toto = Range("A2")
If WorksheetFunction.CountA(Columns("B:D")) = 0 Then GoTo Colonne2
    
x = Application.WorksheetFunction.CountIf(Range("C:C"), "mange")
y = Application.WorksheetFunction.CountIf(Range("C:C"), "boit")
z = Application.WorksheetFunction.CountIf(Range("C:C"), "dort")
a = x
If x 0 And y 0 Then GoTo RepseulC
If a = 0 Then GoTo Miss
If x > 0 Then
Range("B1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange1"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(x).Insert xlShiftDown

For Each c In ActiveSheet.Range("C:C")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("B1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      x = 0

b = y
If b = 0 Then GoTo Rep
If y > 0 Then
Range("C1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit1"
Toto.Offset(1, 0).Activate
ActiveCell.EntireRow.Resize(y).Insert xlShiftDown

For Each c In ActiveSheet.Range("C:C")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      y = 0


If z > 0 Then
Range("D1").Activate
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.EntireColumn.Offset(0, 1).Insert
numColumns = numColumns + 1
Range("D1").Activate
ActiveCell.Value = "dort1"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(z).Insert xlShiftDown

For Each c In ActiveSheet.Range("C:C")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("D1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("E1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      z = 0
      
    u = Application.WorksheetFunction.CountIf(Range("G:G"), "mange")
      If u > 0 Then
Range("F1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "manget2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(u).Insert xlShiftDown

For Each c In ActiveSheet.Range("G:G")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("F1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      u = 0
      
          v = Application.WorksheetFunction.CountIf(Range("G:G"), "boit")
      If v > 0 Then
Range("G1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(v).Insert xlShiftDown

For Each c In ActiveSheet.Range("G:G")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("G1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      v = 0
      
     w = Application.WorksheetFunction.CountIf(Range("G:G"), "dort")
   If w > 0 Then
Range("H1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("H1").Select
ActiveCell.Value = "dort2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(w).Insert xlShiftDown

For Each c In ActiveSheet.Range("G:G")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("H1").Offset(NumRows + 1, 0)
Selection.ClearContents
 rngRed.Offset(0, 1).Activate
 Selection.Copy
ActiveSheet.Paste Destination:=Range("I1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      w = 0
      
          n = Application.WorksheetFunction.CountIf(Range("K:K"), "mange")
      If n > 0 Then
Range("J1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(n).Insert xlShiftDown

For Each c In ActiveSheet.Range("K:K")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("J1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      n = 0
      
          o = Application.WorksheetFunction.CountIf(Range("K:K"), "boit")
      If o > 0 Then
Range("K1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(o).Insert xlShiftDown

For Each c In ActiveSheet.Range("K:K")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("K1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      o = 0
      
     p = Application.WorksheetFunction.CountIf(Range("K:K"), "dort")
 If p > 0 Then
Range("L1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("L1").Select
ActiveCell.Value = "dortt3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(p).Insert xlShiftDown

For Each c In ActiveSheet.Range("K:K")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("L1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("M1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      p = 0
      
Miss:
b = y

If y > 0 Then
Range("B1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit1"
Toto.Offset(1, 0).Activate
ActiveCell.EntireRow.Resize(y).Insert xlShiftDown

For Each c In ActiveSheet.Range("C:C")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("B1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      y = 0
    
     If z > 0 Then
Range("C1").Activate
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
numColumns = numColumns + 1
Range("C1").Activate
ActiveCell.Value = "dort1"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(z).Insert xlShiftDown

For Each c In ActiveSheet.Range("C:C")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("D1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      z = 0
       u = Application.WorksheetFunction.CountIf(Range("F:F"), "mange")
      If u > 0 Then
Range("E1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "manget2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(u).Insert xlShiftDown

For Each c In ActiveSheet.Range("F:F")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("E1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      u = 0
      
       v = Application.WorksheetFunction.CountIf(Range("F:F"), "boit")
      If v > 0 Then
Range("F1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(v).Insert xlShiftDown

For Each c In ActiveSheet.Range("F:F")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("F1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      v = 0
      
      w = Application.WorksheetFunction.CountIf(Range("F:F"), "dort")
    If w > 0 Then
Range("G1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("G1").Select
ActiveCell.Value = "dort2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(w).Insert xlShiftDown

For Each c In ActiveSheet.Range("F:F")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("G1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("H1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      w = 0
      
            
          n = Application.WorksheetFunction.CountIf(Range("J:J"), "mange")
      If n > 0 Then
Range("I1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(n).Insert xlShiftDown

For Each c In ActiveSheet.Range("J:J")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("I1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      n = 0
      
          o = Application.WorksheetFunction.CountIf(Range("J:J"), "boit")
      If o > 0 Then
Range("J1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(o).Insert xlShiftDown

For Each c In ActiveSheet.Range("J:J")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("J1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      o = 0
      
     p = Application.WorksheetFunction.CountIf(Range("J:J"), "dort")
  If p > 0 Then
Range("K1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("K1").Select
ActiveCell.Value = "dortt3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(p).Insert xlShiftDown

For Each c In ActiveSheet.Range("J:J")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("K1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("L1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      p = 0

RepseulC:
MsgBox "debut RepseulC"
  If z > 0 Then
Range("B1").Select
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
Range("B1").Activate
ActiveCell.Value = "dort1"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(z).Insert xlShiftDown
MsgBox "Stop"
For Each c In ActiveSheet.Range("D:D")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -2).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("B1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      z = 0
    u = Application.WorksheetFunction.CountIf(Range("G:G"), "mange")
      If u > 0 Then
Range("F1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "manget2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(u).Insert xlShiftDown

For Each c In ActiveSheet.Range("G:G")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("F1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      u = 0
      
          v = Application.WorksheetFunction.CountIf(Range("G:G"), "boit")
      If v > 0 Then
Range("G1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(v).Insert xlShiftDown

For Each c In ActiveSheet.Range("G:G")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("G1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      v = 0
      
     w = Application.WorksheetFunction.CountIf(Range("G:G"), "dort")
   If w > 0 Then
Range("H1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("H1").Select
ActiveCell.Value = "dort2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(w).Insert xlShiftDown

For Each c In ActiveSheet.Range("G:G")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("H1").Offset(NumRows + 1, 0)
Selection.ClearContents
 rngRed.Offset(0, 1).Activate
 Selection.Copy
ActiveSheet.Paste Destination:=Range("I1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      w = 0
        n = Application.WorksheetFunction.CountIf(Range("K:K"), "mange")
      If n > 0 Then
Range("J1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(n).Insert xlShiftDown

For Each c In ActiveSheet.Range("K:K")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("J1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      n = 0
      
          o = Application.WorksheetFunction.CountIf(Range("K:K"), "boit")
      If o > 0 Then
Range("K1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(o).Insert xlShiftDown

For Each c In ActiveSheet.Range("K:K")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("K1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      o = 0
      
     p = Application.WorksheetFunction.CountIf(Range("K:K"), "dort")
 If p > 0 Then
Range("L1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("L1").Select
ActiveCell.Value = "dortt3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(p).Insert xlShiftDown

For Each c In ActiveSheet.Range("K:K")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("L1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("M1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      p = 0
      
      

Rep:
  If z > 0 Then
Range("C1").Activate
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
numColumns = numColumns + 1
Range("C1").Activate
ActiveCell.Value = "dort1"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(z).Insert xlShiftDown

For Each c In ActiveSheet.Range("C:C")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("D1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      z = 0
       u = Application.WorksheetFunction.CountIf(Range("F:F"), "mange")
      If u > 0 Then
Range("E1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "manget2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(u).Insert xlShiftDown

For Each c In ActiveSheet.Range("F:F")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("E1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      u = 0
      
       v = Application.WorksheetFunction.CountIf(Range("F:F"), "boit")
      If v > 0 Then
Range("F1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(v).Insert xlShiftDown

For Each c In ActiveSheet.Range("F:F")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("F1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      v = 0
      
      w = Application.WorksheetFunction.CountIf(Range("F:F"), "dort")
    If w > 0 Then
Range("G1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("G1").Select
ActiveCell.Value = "dort2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(w).Insert xlShiftDown

For Each c In ActiveSheet.Range("F:F")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("G1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("H1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      w = 0
      
            
          n = Application.WorksheetFunction.CountIf(Range("J:J"), "mange")
      If n > 0 Then
Range("I1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(n).Insert xlShiftDown

For Each c In ActiveSheet.Range("J:J")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("I1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      n = 0
      
          o = Application.WorksheetFunction.CountIf(Range("J:J"), "boit")
      If o > 0 Then
Range("J1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(o).Insert xlShiftDown

For Each c In ActiveSheet.Range("J:J")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("J1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      o = 0
      
     p = Application.WorksheetFunction.CountIf(Range("J:J"), "dort")
  If p > 0 Then
Range("K1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("K1").Select
ActiveCell.Value = "dortt3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(p).Insert xlShiftDown

For Each c In ActiveSheet.Range("J:J")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("K1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("L1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      p = 0


Colonne2:
       u = Application.WorksheetFunction.CountIf(Range("F:F"), "mange")
      If u > 0 Then
Range("B1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "manget2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(u).Insert xlShiftDown

For Each c In ActiveSheet.Range("F:F")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("B1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      u = 0
      
       v = Application.WorksheetFunction.CountIf(Range("F:F"), "boit")
      If v > 0 Then
Range("C1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(v).Insert xlShiftDown

For Each c In ActiveSheet.Range("F:F")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("C1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      v = 0
      
      w = Application.WorksheetFunction.CountIf(Range("F:F"), "dort")
      If w = 0 Then GoTo RienABCpasdortdansF
      If w > 0 Then
Range("D1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("D1").Select
ActiveCell.Value = "dort2"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(w).Insert xlShiftDown

For Each c In ActiveSheet.Range("G:G")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("D1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("E1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      w = 0
                
          n = Application.WorksheetFunction.CountIf(Range("J:J"), "mange")
      If n > 0 Then
Range("F1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(n).Insert xlShiftDown

For Each c In ActiveSheet.Range("J:J")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("F1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      n = 0
      
          o = Application.WorksheetFunction.CountIf(Range("J:J"), "boit")
      If o > 0 Then
Range("G1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(o).Insert xlShiftDown

For Each c In ActiveSheet.Range("J:J")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("G1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      o = 0
      
     p = Application.WorksheetFunction.CountIf(Range("J:J"), "dort")
If p > 0 Then
Range("H1").Activate
ActiveCell.EntireColumn.Offset(0, 1).Insert
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("H1").Select
ActiveCell.Value = "dortt3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(p).Insert xlShiftDown

For Each c In ActiveSheet.Range("K:K")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("H1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("I1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      p = 0
      
RienABCpasdortdansF:
MsgBox "RienABCpasdortdansF"
n = Application.WorksheetFunction.CountIf(Range("I:I"), "mange")
      If n > 0 Then
Range("H1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "mange3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(n).Insert xlShiftDown

For Each c In ActiveSheet.Range("I:I")
If c.Value = "mange" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("H1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      n = 0
      
          o = Application.WorksheetFunction.CountIf(Range("I:I"), "boit")
      If o > 0 Then
Range("I1").Select
NumRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
ActiveCell.Value = "boit3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(o).Insert xlShiftDown

For Each c In ActiveSheet.Range("I:I")
If c.Value = "boit" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("I1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      o = 0
      
     p = Application.WorksheetFunction.CountIf(Range("I:I"), "dort")
 If p > 0 Then
Range("J1").Activate
NumRows = Selection.Rows.Count
numColumns = numColumns + 1
Range("J1").Select
ActiveCell.Value = "dortt3"
Toto.Offset(1, 0).Select
ActiveCell.EntireRow.Resize(p).Insert xlShiftDown

For Each c In ActiveSheet.Range("I:I")
If c.Value = "dort" Then
If rngRed Is Nothing Then Set rngRed = c
rngRed.Offset(0, -1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("J1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.Offset(0, 1).Activate
Selection.Copy
ActiveSheet.Paste Destination:=Range("K1").Offset(NumRows + 1, 0)
Selection.ClearContents
rngRed.ClearContents
NumRows = NumRows + 1
Set rngRed = Nothing
        End If
    Next c
      End If
      p = 0
With ActiveSheet.UsedRange
For iCol = .Column + .Columns.Count - 1 To 1 Step -1
If IsEmpty(Cells(65536, iCol)) And IsEmpty(Cells(1, iCol)) Then
If Cells(65536, iCol).End(xlUp).Row = 1 Then Columns(iCol).mange
End If
Next iCol
End With
End Sub


Bonne fin d'année !
0

Discussions similaires

Boucle définir si c'est un carré parfait
stell-91 -
stell-91 -

10 réponses
texte qui defile en boucle sans espace entre le debut et la fin
cs_wally88 -
Daliiiila -

8 réponses
texte défilant en boucle
SoundBoy771 -
erico29 -

7 réponses
boucle for avec un pas de 2
ludomontbaze -
Renfield -

3 réponses
Automatiser en boucle l'affichage d'un défilement auto pour .pdf sous A Reader
jedebuteenvb -
jedebuteenvb -

4 réponses
Rejoignez-nous