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 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67
| Sub macro()
Dim Chemin As String
Dim Fso As Object
Dim FsoRepertoire As Object
Dim FsoFichier As Object
Dim i As Long
Dim c As Integer
Dim strLigne As String
Dim str() As String
Dim j As Long
Worksheets("Feuil1").Range("A:IV").ClearContents 'suppression des données contenues dans les feuilles
Worksheets("Feuil1").Range("A:IV").ColumnWidth = 10.71
Chemin = Application.InputBox(prompt:="Indiquer le chemin du répertoire contenant les fichiers à importer", Type:=2)
Set Fso = CreateObject("Scripting.FileSystemObject")
Set FsoRepertoire = Fso.GetFolder(Chemin)
'Boucle sur fichiers du repertoire
Cells(1, 1) = "Pic"
Cells(1, 2) = "Fonction"
Cells(1, 3) = "Position du pic"
Cells(1, 4) = "Hauteur du pic"
Cells(1, 5) = "Surface du pic"
Cells(1, 6) = "1/2 largeur à mi hauteur du pic (gauche)"
Cells(1, 7) = "1/2 largeur à mi hauteur du pic (droite)"
Cells(1, 8) = "Largeur à mi hauteur du pic"
i = 2
For Each FsoFichier In FsoRepertoire.Files
'ouvre le fichier
j = 0
Open FsoFichier.Path For Input As #1
'Boucle sur chaque ligne du fichier
Do While Not EOF(1)
Line Input #1, strLigne
j = j + 1
If j > 5 Then
If strLigne = " " Then
i = i + 1
GoTo ferme
End If
str = Split(strLigne, Chr(9))
Cells(i, 1).Value = str(0)
Cells(i, 2).Value = str(1)
Cells(i, 3).Value = str(2)
Cells(i, 4).Value = str(3)
Cells(i, 5).Value = str(4)
Cells(i, 6).Value = str(5)
Cells(i, 7).Value = str(6)
Cells(i, 8) = Cells(i, 6) + Cells(i, 7)
i = i + 1
End If
Loop
ferme:
Close #1
Cells(i - 1, 4) = "Aire sulfure"
Cells(i - 1, 5) = Cells(i - 7, 5) + Cells(i - 6, 5) + Cells(i - 5, 5)
Next
Worksheets("Feuil1").Range("A:IV").NumberFormat = "General"
Worksheets("Feuil1").Range("A:IV").EntireColumn.AutoFit
End Sub |
Partager