Bonjour
Il y a quelque temps j'avais demandé de l'aide pour créer une macro qui importe plusieurs fichiers .txt
Je reviens vers vous car je n'arrive pas à faire ce que je veux.
Je voudrais qu'après avoir importé les fichiers, il me décompte les doubles et les ranges dans une feuille nommer recap.
Ce que je ne sais pas faire c'est rangé le résulta de la feuille étude dans la colonne AB de la feuille recap, le résulta de la feuille étude 2 dans la colonne CD de la feuille recap et ainsi de suite .
Autre chose je ne sais pas pourquoi j'ai un '1' qui traine la fin de la colonne B la ma feuille recape.
Je joins le fichier Excel et les fichier .txt que j'importe.
Cordialement;
Bob
Sub on_y_va()
Dim Repertoire As FileDialog, monRepertoire As String
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Repertoire.Show
If Repertoire.SelectedItems.Count > 0 Then
monRepertoire = Repertoire.SelectedItems(1)
aspirer monRepertoire
Else
MsgBox "Aucun Répertoire Sélectionné"
End If
End Sub
Sub aspirer(ceRepertoire As String)
Dim Fso, SourceFolder, SubFolder, fichier As Object
Dim ws As Worksheet, wrecap As Worksheet
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(ceRepertoire)
' boucle sur tous les fichiers du répertoire
For Each fichier In SourceFolder.Files
If Right(fichier.Name, 4) = ".txt" Then
' création feuille
If Not FeuilleExiste(ThisWorkbook, fichier.Name) Then
Sheets.Add
ActiveSheet.Name = fichier.Name
Set ws = ActiveSheet
Else
Sheets(fichier.Name).Select
Cells.Clear
Set ws = ActiveSheet
End If
N = FreeFile
Open fichier For Input As #N
i = 0
Do While Not EOF(1)
Line Input #N, contenu
i = i + 1
Cells(i, 1).Value = contenu
Loop
Close #N
End If
Next fichier
' appel récursif pour les sous-répertoires
For Each SubFolder In SourceFolder.subfolders
aspirer SubFolder.Path
Next SubFolder
' Compter les doubles
Dim doub As Range
Dim table() As String
Dim flag As Boolean
With ActiveSheet
Set doub = .Range("A2")
ReDim table(1 To 2, 1 To 1)
table(1, 1) = doub
table(2, 1) = 1
For i = 1 To .Columns(1).Find("*", , , , , xlPrevious).Row - 1
flag = True
For j = LBound(table, 2) To UBound(table, 2)
If doub.Offset(i, 0) = table(1, j) Then
table(2, j) = table(2, j) + 1
flag = False
Exit For
End If
Next j
If flag Then
ReDim Preserve table(1 To 2, 1 To (UBound(table, 2) + 1))
table(1, UBound(table, 2)) = doub.Offset(i, 0)
table(2, UBound(table, 2)) = 1
End If
Next i
End With
' Ranger dans l'ordre
With Worksheets("recap")
For i = LBound(table, 2) To UBound(table, 2)
.Range("A2").Offset(i, 0) = table(1, i)
.Range("A2").Offset(i, 1) = table(2, i)
Next i
End With
Sheets("recap").Activate
' Création des titres colonne
With Worksheets("recap")
Range("A1").EntireRow.Select
For i = 1 To Sheets.Count
ActiveCell.Value = Sheets(i).Name
ActiveCell.Offset(0, 1).Select
Next i
End With
Rows("3:33").Select
Selection.Sort Key1:=Range("A2")
ActiveCell.Select
End Sub
Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
On Error Resume Next
FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function
Sub test()
Columns("A3:H3").Select
Selection.Sort Key1:=Range("A2")
ActiveCell.Select
End Sub