Sub ImportAppart()
Dim Ligne As String, Fichier As String
Dim NbLigneEntete As Byte, DernierEtageRempli As Byte, NumEtage As Byte[B], ColNumAppart As Byte[/B]
Dim fs
Application.ScreenUpdating = False
'Definition du fichier texte a importer
Fichier = ThisWorkbook.Path & "\Appart.txt"
'Definition du nombre de ligne d'entete du fichier importé
NbLigneEntete = 2
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.fileexists(Fichier) Then
'si le fichier texte existe
'effacement de la feuille
Feuil1.UsedRange.Clear
'ouverture du fichier texteen mode sequentiel
Open Fichier For Input As #1
'Tant que la fin du fichier n'est pas atteinte
'et qu'on a pas lu toutesles lignes d'entete
Do While Not EOF(1) And NbLigneEntete > 0
'Lecture de la ligne suivante
Line Input #1, Ligne
'decrementation du nombre de ligne d'entete a lire
NbLigneEntete = NbLigneEntete - 1
Loop
'Tant que la fin du fichier n'est pas atteinte
Do While Not EOF(1)
'Lecture de la ligne suivante
Line Input #1, Ligne
'mémorisation du numéro d'etage (les 2 1er caracteres de la ligne)
NumEtage = CByte(Left(Ligne, 2))
'copie du numero d'etage dans la ligne correspondante de la colonne 1
Feuil1.Range("B" & NumEtage) = NumEtage
'Recherche de la 1ere colonne vide sur un etage
[B] If Feuil1.Range("A" & NumEtage).Value = "" Then
ColNumAppart = 1
Else
ColNumAppart = 3
End If[/B]
'Copies des nom et num
'pour le nom de la position 4 sur 30 caracteres en supprimant les espaces a droite
'pour le numero de la position 36 sur 4 caracteres en supprimant les espaces a gauche
Feuil1.Cells(NumEtage, ColNumAppart).Value = RTrim(Mid(Ligne, 4, 30)) & " " & LTrim(Mid(Ligne, 36, 4)) [B]& vbLf & Mid(Ligne, 44, 4)[/B]
Loop
'fermeture du fichier texte
Close #1
'Un peu d'habillage
'Centrage des numeros d'etage
Feuil1.Columns("B").HorizontalAlignment = xlCenter
[B] Feuil1.Columns("B").VerticalAlignment = xlCenter
Feuil1.Columns("B").ColumnWidth = 10[/B]
'Ajustement de la largeur des colonne aux données
[B] Feuil1.Range("A:A,C:C").ColumnWidth = 40[/B]
'tri par numero d'etage en decroissant
Feuil1.UsedRange.Sort key1:=Feuil1.Range("[B]B1[/B]"), Order1:=xlDescending, header:=xlNo
Else
'si on ne ttrouve pas le fichier, un peu message d'alerte
MsgBox "Le fichier '" & Fichier & "' n'existe pas.", vbOKOnly
End If
Application.ScreenUpdating = True
End Sub