Sub ExtractionGED()
Application.ScreenUpdating = False
On Error GoTo Erreur
Dim adresse() As String
Dim j As Integer
Dim Index As Integer
Dim MonFichier As String
Dim Ligne As String
Dim i As Integer
Dim Llig As Integer
Dim PNf As Integer
Dim Pind
Dim naiss As Byte
Dim deces As Byte
Dim Ladr As String
Dim mar As Byte
Dim Fichier As Variant
' le fichier GED original est au format Unix (LF)
' il faut le convertir en windows (CR/ LF)
' une méthode simple est de l'ouvrir avec excel une première fois et de l'enregistrer dans ce format
Fichier = Application.GetOpenFilename("Tous les fichiers (*.txt),*.txt")
If Fichier = False Then Exit Sub
MonFichier = Fichier
Index = FreeFile()
Open MonFichier For Input As #Index
While Not EOF(Index) '
Line Input #Index, Ligne
Llig = Len(Ligne)
PNf = InStr(1, Ligne, "/")
Pind = InStr(1, Ligne, "@")
' N° individu
If Right(Ligne, 6) = "@ INDI" Then
i = i + 1
Range("A" & i).Value = Mid(Ligne, Pind + 1, InStr(1, Ligne, "N") - 7)
End If
' prénom et nom
If Left(Ligne, 6) = "1 NAME" Then
Range("B" & i).Value = Mid(Ligne, 8, PNf - 9)
Range("C" & i).Value = Mid(Ligne, PNf + 1, Llig - PNf - 1)
End If
' date de naissance
If Left(Ligne, 6) = "1 BIRT" Then
naiss = 1
deces = 0
End If
If Left(Ligne, 6) = "2 DATE" And naiss = 1 Then
Range("D" & i).Value = Mid(Ligne, 7, 12)
End If
' Date de décés
If Left(Ligne, 6) = "1 DEAT" Then
deces = 1
naiss = 0
End If
If Left(Ligne, 6) = "2 DATE" And deces = 1 Then
Range("M" & i).Value = Mid(Ligne, 7, 12)
End If
' lieu de naissance
If Left(Ligne, 6) = "2 PLAC" And naiss = 1 Then
Ladr = Mid(Ligne, 8)
adresse = Split(Ladr, ",")
For j = 0 To UBound(adresse)
Range("F" & i).Offset(0, j) = adresse(j)
Next j
End If
' lieu décés
If Left(Ligne, 6) = "2 PLAC" And deces = 1 Then
Ladr = Mid(Ligne, 8)
adresse = Split(Ladr, ",")
For j = 0 To UBound(adresse)
Range("N" & i).Offset(0, j) = adresse(j)
Next j
End If
If Left(Ligne, 7) = "1 SEX M" Then
Range("K" & i).Value = "M"
End If
' sexe
If Left(Ligne, 7) = "1 SEX F" Then
Range("K" & i).Value = "F"
End If
' profession
If Left(Ligne, 6) = "1 OCCU" Then
Range("L" & i).Value = Mid(Ligne, 7)
End If
' Famille
If Left(Ligne, 6) = "1 FAMC" Then
Range("S" & i).Value = "FAMC"
Range("T" & i).Value = Mid(Ligne, Pind + 1, InStr(Pind + 1, Ligne, "@") - Pind - 1)
End If
If Left(Ligne, 6) = "1 FAMS" Then
Range("U" & i).Value = "FAMS"
Range("V" & i).Value = Mid(Ligne, Pind + 1, InStr(Pind + 1, Ligne, "@") - Pind - 1)
End If
Wend
Close #Index ' ferme le fichier
Application.ScreenUpdating = True
Exit Sub
Erreur:
MsgBox Ligne
Application.ScreenUpdating = True
End Sub