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 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
| 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
'Mettre Application.FileSearch en préfixe
compteur = 0
'variable compteur (?) à 0
.NewSearch
'Nouvelle recherche (Application.FileSearch.NewSearch)
.FileType = msoFileTypeWordDocuments
'Type de fichier = document word
.LookIn = ActiveWorkbook.Path
'où regarder = dansle répertoire du classeur actif
.Filename = "*.ri"
'nom = tous les fichiers d'extension ri
If .Execute() > 0 Then
'si la recherche retourne au moins un fichier, alors
compteur = .FoundFiles.Count
'compteur = nombre de fichiers de la recherche
Else
'sinon
.NewSearch
'Lancer une nouvelle recherche
.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")
'reponse = retour de la boîte de dialogue (oui/non)
CurDir ActiveWorkbook.Path
'répertoire courant = répertoire où se situe le classeur actif
If Response = vbNo Then
'Reponse = non alors
Exit Sub
'terminer la macro (sortir)
End If
Nom_complet = .Application.GetOpenFilename("Text Files (*.ri), *.txt")
' Nom complet où les infos brutes se situent
'ouvre la boîte de dialogue "Ouvrir"
If Nom_complet = False Then
'si le fichier à ouvrir n'existe pas
Exit Sub
'sortir
End If
rep = CherRep(Nom_complet)
'rep = retour de la fonction CherRep, avec Nom_complet comme argument
If rep <> "" Then
'si rep n'est pas vide, alors
.LookIn = rep
'la recherche se fera dans le répertoire rep
If .Execute() > 0 Then
'si la recherche retour au moins un fichier
compteur = .FoundFiles.Count
'compteur = nombre de fichiers trouvé
Else
'sinon
Exit Sub
'sortir
End If
Else
'sinon (rep vide)
Exit Sub
'sortir
End If
End If
' Vider le précédent comptage
nbligne = ActiveSheet.UsedRange.Rows(1).Row + ActiveSheet.UsedRange.Rows.Count - 1
'nbligne = pour la plage de travail de la feuille active (numéro de la 1ère ligne + nombre de lignes -1
If ligneinit <= nbligne Then
'si nbligne=>4, alors
Rows(ligneinit & ":" & nbligne).Delete Shift:=xlShiftUp
'supprimer les lignes à partir de la 4ème jusqu'à la dernière
End If
If ligneinit > 1 Then
'si ligneinit>1 alors *********************
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
'Reçoit lavariable chaîne Nom_Complet
'Retourne la variable chaîne CherRep
For pos = Len(Nom_complet) To 1 Step -1
'Pour Pos = Longueur(Nom_Complet) jusqu'à 1 en enlevant 1
If Mid(Nom_complet, pos, 1) = "\" Then
'si la lettre n°pos = "\" alors
Exit For
'Sortir de la boucle
End If
Next pos
'Pos suivant (précédent)
If pos = 0 Then
'si Pos = 0, alors
CherRep = ""
'CherRep = vide
Exit Function
'Sortir
End If
CherRep = Left(Nom_complet, pos) ' Répertoire des infos brutes
'CherRep = le chemin complet, jusqu'au dernier \
End Function |
Partager