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 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
| Sub ibnf()
' A partir d'un répertoire, Prendre tous les fichiers .ri
' Compter les sortes de cartes
Const ligneinit As Integer = 4
Dim SN As String
Dim nom As String
With Application.FileSearch
compteur = 0
.NewSearch
.FileType = msoFileTypeWordDocuments
.LookIn = ActiveWorkbook.Path
.Filename = "*.ri"
If .Execute() > 0 Then
compteur = .FoundFiles.Count
Else
.NewSearch
.FileType = msoFileTypeWordDocuments
.Filename = "*.ri"
Response = MsgBox("Le fichier excel n'est pas dans le répertoire des fichiers RI" _
& Chr(10) & "Rechercher un fichier .ri", _
vbYesNo, "RECHERCHE FICHIER")
CurDir ActiveWorkbook.Path
If Response = vbNo Then
Exit Sub
End If
Nom_complet = .Application.GetOpenFilename("Text Files (*.ri), *.txt")
' Nom complet où les infos brutes se situent
If Nom_complet = False Then
Exit Sub
End If
rep = CherRep(Nom_complet)
If rep <> "" Then
.LookIn = rep
If .Execute() > 0 Then
compteur = .FoundFiles.Count
Else
Exit Sub
End If
Else
Exit Sub
End If
End If
' Vider le précédent comptage
nbligne = ActiveSheet.UsedRange.Rows(1).Row + _
ActiveSheet.UsedRange.Rows.Count - 1
If ligneinit <= nbligne Then
Rows(ligneinit & ":" & nbligne).Delete Shift:=xlShiftUp
End If
If ligneinit > 1 Then
nbligne = ligneinit - 1
Else
nbligne = 0
End If
ActiveSheet.Cells(1, 2).Value = compteur
' commencer à compter
Set fs = CreateObject("Scripting.FileSystemObject")
For num = 1 To compteur
Set fichier = fs.OpenTextFile(.FoundFiles(num))
Do While fichier.AtEndOfStream <> True
laligne = Trim(fichier.ReadLine)
If laligne <> "" Then
If InStr(1, laligne, "USER LABEL :") = 1 Then
longueur = InStr(laligne, ":")
longueur2 = InStr(laligne, "/")
UserLabel = Trim(Mid(laligne, longueur + 2, longueur2 - longueur - 2))
emplacemt = Trim(Mid(laligne, longueur2))
ElseIf InStr(1, laligne, "Unit type :") = 1 Then
LeType = Trim(Right(laligne, Len(laligne) - 11))
ElseIf InStr(1, laligne, "Unit part number : 3") = 1 Then
Code = Trim(Mid(laligne, Len(laligne) - 14, 11))
Indice = Trim(Right(laligne, 4))
ElseIf InStr(1, laligne, "Unit part number : 1") = 1 Then
lecode = Trim(Right(laligne, Len(laligne) - 18))
If Len(lecode) = "12" Then
Code = Trim(Right(laligne, Len(laligne) - 18))
Indice = ""
Else
Code = Trim(Mid(laligne, Len(laligne) - 14, 13))
Indice = Trim(Right(laligne, 2))
End If
ElseIf InStr(1, laligne, "Serial number :") = 1 Then
SN = Trim(UCase(Right(laligne, Len(laligne) - 15)))
ElseIf InStr(1, laligne, "Date (") = 1 Then
DateManu = Format(Trim(Right(laligne, Len(laligne) - 11)), "yy/mm/dd")
'If (InStr(1, Code, "3AL94207") = 1) Or _
' (InStr(1, Code, "3AL94452") = 1) Then
nbligne = nbligne + 1
Cells(nbligne, 1) = emplacemt
Cells(nbligne, 2) = UserLabel
Cells(nbligne, 4) = LeType
Cells(nbligne, 5) = Code
Cells(nbligne, 6) = Indice
Cells(nbligne, 7) = SN
Cells(nbligne, 8).Formula = Format(DateManu, "dd-mm-yyyy")
'End If
End If
End If
Loop
'************* Fermeture du fichier des infos brutes **********
fichier.Close
Next num
Set fs = Nothing
End With
Rows("1:3").Delete Shift:=xlShiftUp
ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\Administrateur\Bureau\MAJ 04012010\IBN-F\rmcsr\ibnf.csv", FileFormat:=xlCSV, CreateBackup:=False
End Sub
Private Function CherRep(ByVal Nom_complet As String) As String
For pos = Len(Nom_complet) To 1 Step -1
If Mid(Nom_complet, pos, 1) = "\" Then
Exit For
End If
Next pos
If pos = 0 Then
CherRep = ""
Exit Function
End If
CherRep = Left(Nom_complet, pos) ' Répertoire des infos brutes
End Function |
Partager