Option Explicit
Dim I As Long
Sub Traitement()
'Compte les lignes et les affiche dans le classeur
Call Comptage
' Ouvre les fichiers txt
Call Ouvrir
' Enregistre les fichiers traités
Call Enregistrement_final
End Sub
Sub Comptage()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Dim Valeur As String ' Stocke la valeur à rechercher
Dim cellule As Range ' Stocke la cellule (objet) trouvée
' Demande la valeur à rechercher
Valeur = InputBox("Entrez le chemin du dossier à traiter", _
"Dossier")
Chemin = Valeur & "\"
I = 1
Application.ScreenUpdating = False
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Valeur & "\")
For Each Fichier In Dossier.Files
'If Left(Fichier.Name, 8) = "TRANSFER" Then
Cells(I, 1) = Fichier.Name
Cells(I, 2) = Fichier.Path
If Right(Fichier.Name, 4) = ".txt" Then Cells(I, 3) = NbreLigne(Fichier.Path)
I = I + 1
'End If
Next
ListeFichier (Chemin)
Application.ScreenUpdating = True
End Sub
Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each SousDossier In Dossier.SubFolders
ListeFichier (Chemin & SousDossier.Name & "\")
For Each Fichier In SousDossier.Files
'If Left(Fichier.Name, 2) = "XM" Then
Cells(I, 1) = Fichier.Name
Cells(I, 2) = Fichier.Path
If Right(Fichier.Name, 4) = ".txt" Then Cells(I, 3) = NbreLigne(Fichier.Path)
I = I + 1
'End If
Next
Next
End Function
Function NbreLigne(Chemin As String) As Integer
Dim MyString As String
Open Chemin For Input As #1
Do While Not EOF(1)
Input #1, MyString
If Left(MyString, 2) = "XM" Then NbreLigne = NbreLigne + 1
Loop
Close #1
End Function
Sub Enregistrement_final()
'Enregistrement du fichier en TXT
Dim Plage As Range
Dim StrTemp As String, NomFichier As String
Dim I As Integer, J As Integer
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Dim Valeur As String ' Stocke la valeur à rechercher
Dim cellule As Range ' Stocke la cellule (objet) trouvée
Valeur = InputBox("Entrez le chemin du dossier à traiter", _
"Dossier")
Chemin = Valeur & "\"
NomFichier = Application.GetSaveAsFilename(Valeur & "\transfer_ok", "Text Files (*.txt), *.txt")
Set Plage = ActiveSheet.UsedRange
Open NomFichier For Output As #1
For I = 1 To Plage.Rows.Count
StrTemp = ""
For J = 1 To Plage.Columns.Count
StrTemp = StrTemp & CStr(Cells(I, J).Text) & Chr(124)
Next J
Print #1, Left(StrTemp, Len(StrTemp) - 1)
Next I
Close #1
End Sub
Sub Ouvrir()
'
' Ouvrir Macro
' Demande la valeur à rechercher
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Dim Valeur As String ' Stocke la valeur à rechercher
Dim cellule As Range ' Stocke la cellule (objet) trouvée
'
Range("A1").Select
Valeur = InputBox("Entrez le chemin du dossier à traiter", _
"Dossier")
Chemin = Valeur & "\"
ChDir Chemin 'ThisWorkbook.Path
Workbooks.OpenText Filename:=Chemin & "\transfer.txt", Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2 _
), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), _
Array(9, 2), Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2), Array(15 _
, 2), Array(16, 2), Array(17, 2), Array(18, 2), Array(19, 2), Array(20, 2), Array(21, 2), _
Array(22, 2), Array(23, 2), Array(24, 2), Array(25, 2), Array(26, 2), Array(27, 2), Array( _
28, 2), Array(29, 2), Array(30, 2), Array(31, 2), Array(32, 2), Array(33, 2), Array(34, 2), _
Array(35, 2), Array(36, 2), Array(37, 2), Array(38, 2), Array(39, 2), Array(40, 2), Array( _
41, 2), Array(42, 2), Array(43, 2), Array(44, 2), Array(45, 2), Array(46, 2), Array(47, 2)) _
, TrailingMinusNumbers:=True
ActiveWindow.SmallScroll ToRight:=8
Range("A1").Select
'Insertion de deux colonnes
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Séparation de la colonne A1 pour tri par date
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
OtherChar:="|", FieldInfo:=Array(Array(0, 2), Array(2, 2)), _
TrailingMinusNumbers:=True
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
' Copier/Coller des valeurs et supprimer colonne B et C
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "=CONCATENATE(C[1],C[2])"
' Selection.FillDown
Range("A1").AutoFill Range("A1:A" & Range("B65536").End(xlUp).Row)
Columns("B:C").Select
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
' End Sub
Const NomFeuille = "transfer"
Const colcritere = "A"
Const PremLig = 1
Dim TabMotsCles
Dim s As String
Dim Lig As Long, DerLig As Long, NumMot As Long, NbMots As Long
Dim trouve As Boolean
' initalisations
TabMotsCles = Array("59M", "59", "13", "13", "JM", "XJ", "XR")
NbMots = UBound(TabMotsCles, 1)
Application.ScreenUpdating = False
With Sheets(NomFeuille)
' dernière ligne
DerLig = .Range(colcritere & 65536).End(xlUp).Row
' traitement de la colonne colcritere
For Lig = DerLig To PremLig Step -1
' met en majuscule la cellule
s = UCase(.Range(colcritere & Lig))
trouve = False
' recherche d'un mot cle dans s
For NumMot = 1 To NbMots
If InStr(1, s, TabMotsCles(NumMot)) > 0 Then
trouve = True
Exit For
End If
Next NumMot
' si trouve mot cle supprimer la ligne lig
If trouve Then
.Range(colcritere & Lig).EntireRow.Delete
End If
Next Lig
End With
Application.ScreenUpdating = True
'
' Appelle la Macro de suppression des lignes vides
' Sub SupprimeRow1()
Dim DerLgn As Integer ' défini la variable voir Integer
Dim Lgn As Integer 'défini la variable
Application.ScreenUpdating = False ' annule le défilement à l'écran
With ActiveSheet 'pour la feuille active ou mettre With Sheets("nom de la feuille")
DerLgn = .Range("A65536").End(xlUp).Row 'Renvoi la dernière ligne utilisée
'de la colonne A si A est la colonne ou tu peux déterminer la plus Grande Valeur de ligne à traiter
End With
For Lgn = DerLgn To 2 Step -1 'on part du bas
If Cells(Lgn, 1).Value = "" Then ' si la cellule est vide
Cells(Lgn, 1).EntireRow.Select ' la ligne est selectionnée
Selection.EntireRow.Delete Shift:=xlUp 'La ligne entière est supprimée par le Haut
End If
Next
Range("A1").Select
Application.ScreenUpdating = True 'réactive le défilement
' Supprimer les lignes vides
Call Enregistrement_final
End Sub