Bonjour tout le monde,
Je suis nouveau dans ce site et je me suis inscrit parce que je rencontre un grand souci avec un dossier dont je suis en charge dans mon entreprise et j'espère que quelqu'un pourrait m'aider parce que je suis dans l'impasse là.
Voilà, je veux créer un macro qui me permettrait de d'aller chercher des informations dans plusieurs fichier excel et les compiler sur un même fichier.
Voici le code que j'ai :
Public chemin As String
Public ceclasseur As String
Public nomxls As String
Public ii As Single
Public derligne As Single
Sub ImportXLSFile()
'Dim ceclasseur As String
'Dim monrépertoire As String
'Dim ii As Integer
'monrépertoire = "nom du répertoire contenant les fichiers .txt à importer"
'Stop
choisirRepertoire
ceclasseur = ThisWorkbook.Name
Set fc = CreateObject("Scripting.FileSystemObject").GetFolder(chemin).Files
If fc.Count > 0 Then 'il y a des fichiers
ii = 0
For Each f1 In fc
If Right(f1.Name, 3) = "xls" Or Right(f1.Name, 3) = "XLS" Then 'c'est un fichier texte
'ii = ii + 1
nomxls = f1.Name
ii = ActiveSheet.Range("C65536").End(xlUp).Row
'Workbooks.OpenText Filename:= _
chemin & "\" & f1.Name, Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Semicolon:=True
'Workbooks.Open Filename:=f1.Name
Workbooks.Open Filename:=chemin & "\" & nomxls 'inclu_nom_fichier début
Sheets("TEST").Select
derligne = ActiveSheet.Range("C65536").End(xlUp).Row
Range("A1:A" & derligne).Select
Selection.Insert Shift:=xlToRight
Selection.FormulaR1C1 = f1.Name
'inclu_nom_fichier fin
derligne = ActiveSheet.Range("C65536").End(xlUp).Row
'Rows(1).Copy Workbooks(ceclasseur).Sheets(1).Range("A" & ii + 1)
Rows(17 & ":" & derligne).Copy Workbooks(ceclasseur).ActiveSheet.Range("A" & ii + 1) 'Attention "Rows (2 " permet de ne pas copier le titre des fichier
ActiveWorkbook.Close savechanges:=False
End If
Next
End If
'Columns("A:IV").Select
'Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub
Sub choisirRepertoire()
' dl
'Racine = Range(R).Value
activedir = "C:\"
'Stop
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire pour" & choix, &H1&, activedir)
On Error Resume Next
'MsgBox objFolder.Title
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path
If objFolder.Title = "" Then chemin = ""
x = InStr(objFolder.Title, ":")
If x > 0 Then chemin = Mid(objFolder.Title, x - 1, 2) & ""
If Not Len(chemin) = 0 Then Range(R) = chemin
End Sub
Ce n'est pas moi qui l'avais écrit ce code mais un collègue qui l'avait récupéré dans ce forum. Mais le soucis c'est que sur ce code, les données à sélectionner commencaient à la ligne 14 et maintenant c'est à partir de la ligne 17. et avec ce code le macro copié aussi les formules présentent dans les cellules ca que je souhaite supprimé aussi.
Je compte vivement sur votre aide pour pouvoir enfin continuer.
Merci d'avance
Je suis nouveau dans ce site et je me suis inscrit parce que je rencontre un grand souci avec un dossier dont je suis en charge dans mon entreprise et j'espère que quelqu'un pourrait m'aider parce que je suis dans l'impasse là.
Voilà, je veux créer un macro qui me permettrait de d'aller chercher des informations dans plusieurs fichier excel et les compiler sur un même fichier.
Voici le code que j'ai :
Public chemin As String
Public ceclasseur As String
Public nomxls As String
Public ii As Single
Public derligne As Single
Sub ImportXLSFile()
'Dim ceclasseur As String
'Dim monrépertoire As String
'Dim ii As Integer
'monrépertoire = "nom du répertoire contenant les fichiers .txt à importer"
'Stop
choisirRepertoire
ceclasseur = ThisWorkbook.Name
Set fc = CreateObject("Scripting.FileSystemObject").GetFolder(chemin).Files
If fc.Count > 0 Then 'il y a des fichiers
ii = 0
For Each f1 In fc
If Right(f1.Name, 3) = "xls" Or Right(f1.Name, 3) = "XLS" Then 'c'est un fichier texte
'ii = ii + 1
nomxls = f1.Name
ii = ActiveSheet.Range("C65536").End(xlUp).Row
'Workbooks.OpenText Filename:= _
chemin & "\" & f1.Name, Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Semicolon:=True
'Workbooks.Open Filename:=f1.Name
Workbooks.Open Filename:=chemin & "\" & nomxls 'inclu_nom_fichier début
Sheets("TEST").Select
derligne = ActiveSheet.Range("C65536").End(xlUp).Row
Range("A1:A" & derligne).Select
Selection.Insert Shift:=xlToRight
Selection.FormulaR1C1 = f1.Name
'inclu_nom_fichier fin
derligne = ActiveSheet.Range("C65536").End(xlUp).Row
'Rows(1).Copy Workbooks(ceclasseur).Sheets(1).Range("A" & ii + 1)
Rows(17 & ":" & derligne).Copy Workbooks(ceclasseur).ActiveSheet.Range("A" & ii + 1) 'Attention "Rows (2 " permet de ne pas copier le titre des fichier
ActiveWorkbook.Close savechanges:=False
End If
Next
End If
'Columns("A:IV").Select
'Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub
Sub choisirRepertoire()
' dl
'Racine = Range(R).Value
activedir = "C:\"
'Stop
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire pour" & choix, &H1&, activedir)
On Error Resume Next
'MsgBox objFolder.Title
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path
If objFolder.Title = "" Then chemin = ""
x = InStr(objFolder.Title, ":")
If x > 0 Then chemin = Mid(objFolder.Title, x - 1, 2) & ""
If Not Len(chemin) = 0 Then Range(R) = chemin
End Sub
Ce n'est pas moi qui l'avais écrit ce code mais un collègue qui l'avait récupéré dans ce forum. Mais le soucis c'est que sur ce code, les données à sélectionner commencaient à la ligne 14 et maintenant c'est à partir de la ligne 17. et avec ce code le macro copié aussi les formules présentent dans les cellules ca que je souhaite supprimé aussi.
Je compte vivement sur votre aide pour pouvoir enfin continuer.
Merci d'avance