Modifications conditionnelles récurentes

Le 28/03/2010 à 21:46

Nouvel inscrit, je salue toute l'équipe d'animation, ainsi que tous les futurs lecteurs de ce message.

Quelques explications, situation :

Les généalogistes s'échangent souvent leurs données au moyen de fichiers "Gedcom" (*.ged).

Pour modifier ces fichiers on peut les ouvrir très facilement dans Excel. On obtient un tableau d'une colonne qui peut comporter plusieurs milliers de lignes.

Si on souhaite pas transmettre des données que l'on considère confidentielles, il faut les marquer.

Tous les logiciels de généalogie ne permettent pas de le faire par lot, mais uniquement dans la fiche de chaque individu. S'il y a beaucoup de données à marquer, cela devient vite fastidieux et on risque d'en oublier. C'est là que peut intervenir une "automatisation avec Excel. Si on veut, par exemple, cacher tous les évènements postérieurs à une date particulière.

Le besoin :

Dans le tableau créé, il s'agit de rechercher une chaîne de caractères contenant "2 DATE" et la variable "JJ MMM AAA" à choisir selon le besoin, puis d'insérer une ligne avant la ligne contenant ces caractères et d'y inscrire "2 RESN Privacy".

Il suffit ensuite de ré-importer le fichier dans le logiciel de généalogie, puis l'exporter une nouvelle fois en "Gedcom", en excluant les évènements précédemment marqués.

J'espère que mes indications sont compréhensibles et que quelqu'un pourra m'aider, je joins également deux petits fichiers tests, l'un originel, l'autre modifié.

Avec tous mes remerciements à ceux qui pourront m'aider, et aider également d'autres généalogistes si l'auteur m'autorise à communiquer la solution.

Nota : j'ai Zippé mes deux fichiers, car les extensions *.ged ne sont pas acceptées en fichiers joints.

17essai.zip (2.64 Ko)
Le 29/03/2010 à 00:00

Bonjour et bienvenue sur le forum albert,

Tu peux essayer avec cette macro (avec en prime un petit surlignage des cellules concernées) :

Sub genealogie()
Dim temp As Date, critDate As Date
Dim cel As Range, plg As String

    critDate = InputBox("Entrez une date." & vbCrLf & _
                        "(Les évènements strictement postérieurs à cette date seront traités)")
    Application.ScreenUpdating = False
    For Each cel In Range("A1:A" & [A65536].End(xlUp).Row)
        If cel Like "*2 DATE*" Then
            If cel Like "*FEB*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "FEB", "FÉV")
            ElseIf cel Like "*APR*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "APR", "AVR")
            ElseIf cel Like "*MAY*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "MAY", "MAI")
            ElseIf cel Like "*JUN*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "JUN", "JUIN")
            ElseIf cel Like "*JUL*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "JUL", "JUIL")
            ElseIf cel Like "*AUG*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "AUG", "AOÛT")
            End If
            If temp > critDate Then plg = plg & cel.Address() & ","
        End If
    Next cel

    With Range(Left(plg, Len(plg) - 1))
        .Interior.ColorIndex = 6
        .Insert Shift:=xlDown
    End With

    With [A:A].SpecialCells(xlCellTypeBlanks)
        .Interior.ColorIndex = 7
        .Value = "2 RESN Privacy"
    End With

End Sub

Le fichier test qui va avec :

22g-branche-paternelle-essai-2010-03-23.zip (9.79 Ko)
Le 29/03/2010 à 19:13

Bonsoir,

Merci, j'ai testé et il y a quelques petits problèmes :

J'ai choisi comme date maxi 1949, mais la macro a inséré une ligne avant les lignes 56, 80, 152 et 222 qui contiennent des dates inférieures à 1949, par contre les lignes 194 et 210 ont été oubliées, bien que supérieures à 1949.

Je joins le fichier modifié.

Merci de votre réponse.

Cordialement

Gilbert.

9copie-de-g-branche-paternelle-essai-2010-03-23-8.zip (11.60 Ko)
Le 29/03/2010 à 20:23

bonjour albert, forum,

Quelques oublis de ma part. Essaie avec cette macro modifiée :

Sub genealogie()
Dim temp As Date, critDate
Dim cel As Range, plg As String

    critDate = InputBox("Entrez une date." & vbCrLf & _
                        "(Les évènements strictement postérieurs à cette date seront traités)")
    If Not IsDate(critDate) Then MsgBox "Veuillez saisir une date valide": Exit Sub
    critDate = CDate(critDate)
    Application.ScreenUpdating = False
    For Each cel In Range("A1:A" & [A65536].End(xlUp).Row)
        If cel Like "*2 DATE*" Then
            If cel Like "*FEB*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "FEB", "FÉV")
            ElseIf cel Like "*APR*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "APR", "AVR")
            ElseIf cel Like "*MAY*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "MAY", "MAI")
            ElseIf cel Like "*JUN*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "JUN", "JUIN")
            ElseIf cel Like "*JUL*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "JUL", "JUIL")
            ElseIf cel Like "*AUG*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "AUG", "AOÛT")
            ElseIf cel Like "*DEC*" Then
                temp = Replace(Replace(cel, "2 DATE ", ""), "DEC", "DÉC")
            Else
                temp = Replace(cel, "2 DATE ", "")
            End If
            If temp > critDate Then plg = plg & cel.Address() & ","
        End If
    Next cel

    With Range(Left(plg, Len(plg) - 1))
        .Interior.ColorIndex = 6
        .Insert Shift:=xlDown
    End With

    With [A:A].SpecialCells(xlCellTypeBlanks)
        .Interior.ColorIndex = 7
        .Value = "2 RESN Privacy"
    End With

End Sub
Le 29/03/2010 à 22:16

Bonsoir,

Désolé, mais comme je ne connais rien à VBA, je ne suis pas capable de corriger les erreurs.

Cette fois, la macro se bloque avec le message :

Erreur d'exécution "13"

incompatibilté de type

Le deboggage s'arrête sur la ligne :

temp = replace (cel, "2 DATE", "")

A noter que pour la saisie d'une date maximale, l'année suffit, il n'y a pas besoin de saisir, ni le jour, ni le mois.

Merci pour la suite.

Gilbert.

Le 29/03/2010 à 23:20

Re,

Albert-g37 a écrit :

A noter que pour la saisie d'une date maximale, l'année suffit, il n'y a pas besoin de saisir, ni le jour, ni le mois.

Fallait le dire ! Ça facilite la tâche

Teste avec le fichier suivant :

11copie-de-copie-de-g-branche-paternelle-essai-2010-03-23-8.zip (10.98 Ko)

la macro associée :

Sub genealogie()
Dim temp As Integer, critDate As Integer
Dim cel As Range, plg As String

    critDate = InputBox("Entrez une année." & vbCrLf & _
                        "(Les évènements dont l'année est strictement supérieure à l'année saisie seront traités)")
    Application.ScreenUpdating = False

    For Each cel In Range("A1:A" & [A65536].End(xlUp).Row)
        If cel Like "*2 DATE*" Then
            If Right(cel, 4) > critDate Then plg = plg & cel.Address() & ","
        End If
    Next cel

    With Range(Left(plg, Len(plg) - 1))
        .Interior.ColorIndex = 6
        .Insert Shift:=xlDown
    End With

    With Range("A1:A" & [A65536].End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
        .Interior.ColorIndex = 7
        .Value = "2 RESN Privacy"
    End With

End Sub

Cette macro est (pour l'instant ?) basique. C'est-à-dire qu'il n'y a pas de gestion d'erreurs (pas de vérifications si le nombre entré est bien une année, si ce n'est pas des lettres, si c'est pas vide...).

Ensuite, dans la macro, j'ai supposé que si la cellule contient "2 DATE", alors elle contient aussi une date sous forme JJ MMM AAAA.

Quoi qu'il en soit, si problème(s), revient.

3suivi-et-gestion-voucher-modifier.xlsm (42.33 Ko)
Le 30/03/2010 à 18:32

Bonjour et merci,

Désolé, mais je crois que je n'ai pas donné assez de détail. Quand on est dans un domaine, on pense que c'est évident et on ne se met pas toujours à la place de l'interlocuteur.

Je joins donc un fichier "Gedcom" d'une "vraie" généalogie, et non pas un fichier simplifié pour test.

En effet, la nouvelle macro se bloque avec ce fichier et donne le message d'erreur suivant :

Erreur d'exécution '1004' :

La méthode 'Range' de l'objet '_Global' a échoué

En fait, dans la ligne qui contient "2 DATE", la date peut avoir des formats différents et c'est peut-être de là que vient l'erreur :

AAA

AAAA

MMM AAA

MMM AAAA

J MMM AAA

J MMM AAAA

JJ MMM AAA

JJ MMM AAAA

BEF AAA

BEF MMM AAA

BEF AAAA

BEF MMM AAAA

ABT AAA

ABT MMM AAA

ABT AAAA

ABT MMM AAAA

et

@#DJULIAN@ suivi d'un des formats précédents.

J'espère que je n'en ai pas oublié !

Voila çà se complique et je comprendrais très bien que tu n'ai pas assez de temps à consacrer à ma demande.

Mais si tu souhaites continuer, encore merci.

Gilbert

9louis-xiv-essai2.zip (16.79 Ko)
Le 30/03/2010 à 21:47

Bonjour gilbert, forum,

En fait c'est un problème de dimension. On va tenter une autre approche (un peu plus longue à exécuter). Voir fichier :fichier supprimé. Voir fichier post plus bas

Si les couleurs te gênent, on peut les enlever.

Le 30/03/2010 à 23:09

Bonsoir à vba-new, forum,

Il doit y avoir une petite erreur de manipulation des fichiers, car celui qui est en pièce jointe, avec l'indice 3 est identique à celui que j'ai envoyé auparavant avec l'indice 2 et il ne contient pas de macro.

Dur, dur de vouloir rendre service !

Les clients sont souvent insatisfaits !!

Bien cordialement et bonne nuit, un peu de repos sera le bienvenu.

Gilbert.

capture
Le 01/04/2010 à 11:12

Bonjour à tous,

Autant pour moi

Voici le nouveau fichier :

21louis-xiv-essai4.zip (58.38 Ko)

J'ai supprimé le fichier du post précédent.

Le 01/04/2010 à 21:19

Bonsoir vba-new, forum,

La macro a l'air de fonctionner, mais tu as inventé le mouvement perpétuel ! En effet, elle tourne sans arrêt, et quand elle arrive à la dernière ligne, elle recommence au début, insérant ainsi une seconde nouvelle ligne avant la ligne à marquer, puis au tour suivant une troisième ligne, etc...

Je crois qu'il lui manque un "STOP", mais comme je l'ai déjà dit, je ne connais pas VBA et je ne sais pas où le placer.

Par ailleurs, qu'elle est la meilleure méthode, par la suite, pour inclure cette macro dans un fichier, le modifier et enlever la macro une fois le fichier modifié pour éviter de perturber la "ré-importation" dans le logiciel de généalogie.

Merci de me décrire la procédure, si ce n'est pas trop abuser de ta gentillesse.

Bien cordialement.

Gilbert.

4test-dbsv5.xlsm (147.50 Ko)
Le 01/04/2010 à 22:28

Bonsoir gilbert, forum,

Un petit problème dans la macro

Voici la mise à jour (j'ai enlevé les couleurs, au cas où la réimportation des données ne marcherait pas) :

Sub genealogie_3()
Dim c As Range, critDate As Integer
Dim premier As String

   critDate = InputBox("Entrez une année." & vbCrLf & _
                        "(Les évènements dont l'année est strictement supérieure à l'année saisie seront traités)")
   Application.ScreenUpdating = False

   Set c = [A:A].Find("2 DATE", , xlValues, xlPart)
    If Not c Is Nothing Then
      premier = IIf(CInt(Right(c, 4)) > critDate, c.Offset(1).Address, c.Address)
      Do
      If CInt(Right(c, 4)) > critDate Then
        With c
        '.Interior.ColorIndex = 6
        .Insert xlDown
          With .Offset(-1)
          .Value = "2 RESN Privacy"
          '.Interior.ColorIndex = 7
          End With
        End With
      End If
      Set c = [A:A].FindNext(c)
      Loop While Not c Is Nothing And c.Address <> premier
    End If

End Sub

Bon plutôt que de joindre un fichier, je vais te montrer comment intégrer une macro dans un fichier excel.

  • Dans ton fichier excel, appuie simultanément sur ALT+F11 pour ouvrir l'éditeur VBA (tu peux également aller dans Outils / Macro / Visual Basic Editor).
  • Dans la fenêtre de gauche (appelée Projet - VBAProject), fais un clic droit sur le nom de ton fichier puis va dans Insertion / Module. Colle ensuite le code ci-dessus dans la fenêtre qui s'ouvre.
  • Pour lancer la macro, reviens dans ton fichier excel puis clique sur Outils / Macro / Macros puis sur la macro genealogie_v3
  • Une fois l'exécution de la macro terminée, pour supprimer la macro, retourne dans l'éditeur VBA, fais un clic droit sur le module que tu as créé plus haut (qui devrait s'appeler Module1) puis clique sur Supprimer Module1. Dans la boîte de dialogue qui s'ouvre, clique sur "Non".

Voilà ça devrait le faire, si tu as un problème, reviens !

Le 02/04/2010 à 18:34

Bonsoir vba-new, forum,

Merci beaucoup, tout fonctionne très bien, mais j'ai fait une petite erreur qui empêchait le bon fonctionnement de mon fichier "ré-importé" dans le logiciel de généalogie, à savoir :

dans la ligne insérée, il faut écrire '2 RESN privacy' et non pas '2 RESN Privacy', privacy sans 'p' majuscule !

Il s'en faut souvent de peu pour tout bloquer.

M'autorises-tu à transmettre cette macro à d'autres généalogistes qui pourront en avoir besoin ?

Encore merci pour tout et surtout de ta patience.

Super forum et grand merci à tous les animateurs de l'avoir créé.

Très cordialement et bonne fin de semaine à tous.

Gilbert

Le 02/04/2010 à 22:37

Bonjour gilbert, forum,

Albert-g37 a écrit :

M'autorises-tu à transmettre cette macro à d'autres généalogistes qui pourront en avoir besoin ?

Bien sûr ! De toute façon, même si les utilisateurs de cette macro me payaient des royalties, je pense que je n'irais pas bien loin

De plus, comme je voulais faire au plus simple, cette macro ne prend pas compte le cas où des caractères alphanumériques sont entrés. La nouvelle version suivante en tient compte :

Sub genealogie_v4()
Dim c As Range, critDate
Dim premier As String

    critDate = Application.InputBox("Entrez une année." & vbCrLf & _
                                    "(Les évènements dont l'année est strictement supérieure à l'année saisie seront traités)", Type:=1)
    If VarType(critDate) = vbBoolean Then Exit Sub
    If critDate Like "*,*" Then MsgBox "Veuillez entrer un nombre entier", vbExclamation: Exit Sub
    Application.ScreenUpdating = False

    Set c = [A:A].Find("2 DATE", , xlValues, xlPart)
    If Not c Is Nothing Then
        premier = IIf(CInt(Right(c, 4)) > critDate, c.Offset(1).Address, c.Address)
        Do
            If CInt(Right(c, 4)) > critDate Then
                With c
                    '.Interior.ColorIndex = 6
                    .Insert xlDown
                    With .Offset(-1)
                        .Value = "2 RESN privacy"
                        '.Interior.ColorIndex = 7
                    End With
                End With
            End If
            Set c = [A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> premier
    End If

End Sub
Le 03/04/2010 à 20:46

Bonsoir vba-new, forum,

Merci encore pour cette aide.

Tout fonctionne parfaitement et je crois que je vais faire des heureux.

C'est super !

Je vais pouvoir clore ce sujet et je vous salue tous très cordialement.

A une prochaine fois pour une autre aventure

Gilbert

Rechercher des sujets similaires à "modifications conditionnelles recurentes"