Insertion lignes.

Version imprimable

14/03/2019, 15h14
olkvkd

2 pièce(s) jointe(s)

Insertion lignes.

Bonjour à tous,
Suite au plantage de mon précédant ordinateur, j'ai perdu un logiciel qui malheureusement n’existe plus, c'était un shareware qui permettait de gérer une pension canine.
Heureusement j'ai pu récupérer le disque dur mais lorsque je lance le programme bien sûr le code d'activation ne correspond plus et je ne peux que l'ouvrir en mode "évaluation".
Malgré cela j'ai pu exporter mes données vers Excel mais ces différentes données sont dans plusieurs classeurs qu'il faut que je réorganises.

Je voudrai savoir s'il serait possible de créer une macro ou autre pour laisser un espace de 6 lignes à chaque fois que dans la colonne A se trouve "Mr ou Mme".
Voici mon tableau actuel

Pièce jointe 457926

Et voilà ce que je voudrai

Pièce jointe 457929

Je vous remercie par avance.
Patrick

Bonjour

à la vollée

Code:

1
2
3
4
5
6
7
8
9
10
sub test
dim Lastlig as long, i as long
 
with worksheets("Feuil1") ' à adapter
   lastlig=.cells(.rows.count,1).end(xlup).row 
   for i=lastlig to 4 step-1
          if instr("Mr|Mme",.cells(i,1).value) then .rows(i).resize(6).insert
   next i
end with
end sub

14/03/2019, 15h29
vinc_bilb

Bonjour,

Et bien, je pense que c'est tout à fait possible de faire celà avec un bout de code VBA.
Il n'est pas dans les objectifs du forum de vous fournir une solution clé en main.

Je vous propose quelques pistes, suivant votre volonté ou non d'aller sous VBA:
1. Lancer l'enregistreur de Macro
2. Faites quelques modifications sous excel (insertion lignes) et stopper l'enregistrement et regardez le code généré

A partir de là, c'est un peu à vous de jouer avec possiblement un peu de support par le forum.

Bonne continuation .... Il y a plein d'optimisation possibles, par exemple en passant par le specialCells
14/03/2019, 15h50
olkvkd

Citation:

Envoyé par vinc_bilb

Bonjour et merci pour votre aide,
en effet j'ai pu voir sur le forum qu'on pouvait faire un enregistrement mais étant novice en VBA, je n'ai pas réussi à reproduire ce que je voulais.
Cdlt

Citation:

Envoyé par mercatog

Merci beaucoup,
Je l'essaierai ce soir et j'essaierai de comprendre le code...
Encore merci
Cdlt

Salut,
Salut au grand manitou,

C'est sioux!

A adapter (au niveau dressage, début de ligne...) et tester

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Option Explicit
Option Compare Text
 
Public Sub inset_rows()
 
Dim derlign As Integer, l As Integer, k As Integer, d As Integer
 
With Worksheets(1)
        derlign = .Cells(.Rows.Count, 1).End(xlUp).Row
        For l = derlign To 1 Step -1
                With .Cells(l, 1)
                        If .Value = "Mr" Or .Value = "Mme" Then
                                k = .End(xlUp).Row
                                If (l - k) <= 6 Then
                                        Do
                                                .EntireRow.Insert
                                                'Debug.Print Cells(l, 1).End(xlDown).Row
                                                'Debug.Print Cells(l, 1).End(xlUp).Row
                                                d = Cells(l, 1).End(xlDown).Row - Cells(l, 1).End(xlUp).Row
                                        Loop Until d = 6
                                End If
                        End If
                End With
        Next l
        .Rows("1:6").EntireRow.Delete
End With
 
End Sub

14/03/2019, 19h41
olkvkd

Bonsoir,
j'ai essayé les différente solution mais ça ne fonctionne pas, j'ai des erreurs lors de l’exécution.
Je suis novice dans le VBA.
Merci
15/03/2019, 08h28
MarcelG

Bonjour,

Le code fonctionne sur mon poste.

Citation:

j'ai des erreurs lors de l’exécution

Lesquelles?
Sur quelle ligne de code - généralement - surlignée en jaune.
Comme tu peux le constater dans mon code,
La colonne testée est la 1ère
Le balayage des lignes s'effectue depuis la dernière informée de cette colonne jusqu'à la première.

Essaie de tenir compte de ces remarques en adaptant ma proposition et reviens en précisant les points d'achoppement (message d'erreur, ligne...).
15/03/2019, 14h51
olkvkd
Bonjour,
Merci de bien vouloir m'aider.
En fait la macro met beaucoup de temps à s'exécuter.
La colonne à tester est bien la A. seulement je viens de m'apercevoir et je m'en excuse que j'ai d'autres variables du type "Mr/Mme", "Mme/Mr", "Mlle".
Dans le code que tu m'as fourni, j'ai essayé de le modifier comme suit:
Code:

1 2 If .Value = "Mr" Or .Value = "Mme Or .Value = "Mr/Mme" Or .Value = "Mme/Mr" Or .Value = "Mlle" Then k = .End(xlUp).Row
Seulement j'ai des erreurs de syntaxes.

Maintenant si je veux mettre 7 lignes vides au lieu de 6, il faut que je remplace tous les 6 par des 7?

Cdlt. Patrick
15/03/2019, 15h00
MarcelG

Bonjour,

Citation:

Seulement j'ai des erreurs de syntaxes.

Lesquelles?
Quelle(s) ligne(s) est (sont) surlignée(s) par le débuggeur?

Une astuce.
Si M est le facteur commun de tes critères et qu'il exclut les autres, alors tu peux coder

Code:

If (Instr(.Value, "Mr") + Instr(.Value, "Mme") + Instr(.Value, "Mle")) > 0 Then
15/03/2019, 16h41
olkvkd

Citation:

Erreur d'exécution "6" Dépassement de capacité

ci-joint la ligne surlignée en jaune

Code:

d = Cells(l, 1).End(xlDown).Row - Cells(l, 1).End(xlUp).Row

Et sur la feuille Excel je saute de la ligne 965 à la 33768

Bonjour MarcelG,
Bon tout est OK, en fait le problème venait que dans ma colonne A à un moment j'avais un intervalle supérieur.
Donc j'ai modifié ta formule pour mettre un intervalle de 10 et ça fonctionne.
Je te remercie pour le temps que tu m'a accordé.
Cdlt.

Ci-joint ta formule avec ma modif:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Option Explicit
Option Compare Text
 
Public Sub inset_rows()
 
Dim derlign As Integer, l As Integer, k As Integer, d As Integer
 
With Worksheets(1)
        derlign = .Cells(.Rows.Count, 1).End(xlUp).Row
        For l = derlign To 1 Step -1
                With .Cells(l, 1)
                If (InStr(.Value, "Mr") + InStr(.Value, "Mme") + InStr(.Value, "Mlle")) > 0 Then
 
                        'If .Value = "Mr" Or .Value = "Mme" Then
                                k = .End(xlUp).Row
                                If (l - k) <= 10 Then
                                        Do
                                                .EntireRow.Insert
                                                'Debug.Print Cells(l, 1).End(xlDown).Row
                                                'Debug.Print Cells(l, 1).End(xlUp).Row
                                                d = Cells(l, 1).End(xlDown).Row - Cells(l, 1).End(xlUp).Row
                                        Loop Until d = 10
                                End If
                        End If
                End With
        Next l
        .Rows("1:10").EntireRow.Delete
End With
 
End Sub

15/03/2019, 16h55
MarcelG

Salut,

D'accord.

Comme nous sommes au post #10, peux-tu retourner ta feuille en la purgeant de données confidentielles éventuelles.
Je verrai cela lundi après-midi.

Bon week-end à toi, Bon week-end au Forum.

Salut Olkvkd, Bonjour le Forum,

Nos post se sont croisés.

Pour la gestion des intervalles supérieurs 6 lignes vides entre sur la colonne A, voici une proposition

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Option Explicit
Option Compare Text
 
Public Sub insert_rows()
 
Dim derlign As Integer, l As Integer, k As Integer, d As Integer
 
With Worksheets(1)
        derlign = .Cells(.Rows.Count, 1).End(xlUp).Row
        For l = derlign To 2 Step -1
                With .Cells(l, 1)
                        If .Value = "Mr" Or .Value = "Mme" Then
                                k = .End(xlUp).Row
                                Select Case True
                                        Case (l - k) < 7
                                                Do
                                                        .EntireRow.Insert
                                                        'Debug.Print Cells(l, 1).End(xlDown).Row
                                                        'Debug.Print Cells(l, 1).End(xlUp).Row
                                                        d = Cells(l, 1).End(xlDown).Row - Cells(l, 1).End(xlUp).Row
                                                Loop Until d = 7
                                        Case (l - k) > 7
                                                Do
                                                        'Debug.Print l & " / " & k & " / " & Cells(l, 1).End(xlUp).Row
                                                        .End(xlUp).Offset(1, 0).EntireRow.Delete
                                                        'Debug.Print Cells(l, 1).End(xlDown).Row
                                                        d = Cells(l, 1).Row - Cells(l - 1, 1).End(xlUp).Row
                                                Loop Until d = 7
                               End Select
                        End If
                End With
        Next l
        .Rows("2:6").EntireRow.Delete
End With
 
End Sub

Au passage, tu remarqueras

Code:

Option Compare Text

Cette ligne rend inutile la gestion des majuscules et minuscules.
Dans ce cas,

Citation:

Mr = MR = mR = mr