Macro Excel pr concatener plusieurs fichiers
SERIEUXETCOOL
Messages postés
336
Date d'inscription
Statut
Membre
Dernière intervention
-
SERIEUXETCOOL Messages postés 336 Date d'inscription Statut Membre Dernière intervention -
SERIEUXETCOOL Messages postés 336 Date d'inscription Statut Membre Dernière intervention -
Bonjour tout le monde,
C'est mon premier post ici alors je ne sais pas trop si je suis au bon endroit. D'avance je m'excuse.
Je viens vous demander un peu d'aide (beaucoup en fait !). Je viens de découvrir les macros sous Excel. Je sais qu'il existe 2 manière de procéder : sois en programmant par code sois en enregistrant une macro action par action de manière automatique. Je suis donc vraiment novice.
Voila mon objectif :
Dans un dossier disponible sur le pc, j'enregistre plusieurs fichiers .txt (14 fichiers environs). Ces fichiers ont la particularité d'avoir TOUJOURS le même nombre de colonnes (5 colonnes) mais pas forcément le même nombre de lignes (de 0 à 3000 lignes).
Ci après je vous donne un exemple d'un fichier pour mieux voir.
FICHIER 1 :
0 2 4 9 2,2
3 6 7 1 5,6
FICHIER 2 :
3 0 2 3 10
3 2 4 7 89
2 1 1 3 0,01
3 4 1 3 2
Donc le nombre de colonnes est fixe, le nombre de lignes variable et le contenu est exclusivement du nombre.
Je peux avoir plusieurs fichiers de ce type avec plus de lignes. J'aimerais disposer d'un fichier Excel avec une seule Macro à l'intérieure. A partir de l'onglet Formulaire d'Excel j'aimerais insérer un gro bouton qui serait la seule interface avec l'utilisateur. Pour que sa sois simple. Jusque la j'ai réussi à trouver mon bonheur (facile pour vous ? Je sais lol)
La ou sa se corse... Lorsque que je clique sur ce bouton formulaire j'aimerais déclencher ma Macro qui me demande alors de sélectionner mon premier fichier qui se trouve dans un dossier quelconque du PC. Ensuite le contenu du fichier s'ouvre dans un NOUVEAU fichier Excel. Puis automatiquement la macro me demande de sélectionner le fichier suivant qui vas alors s'ouvrir dans le même fichier Excel précédant ET à la suite de l'autre.
La encore pour mieux comprendre je vous donne le résultat estompé.
FICHIER 3 :
0 2 4 9 2,2
3 6 7 1 5,6
3 0 2 3 10
3 2 4 7 89
2 1 1 3 0,01
3 4 1 3 2
La Macro doit permettre de stopper le processus d'importation des fichiers à un moment. C'est à dire si je veux importer 2 fichiers, et bien que je puisse à un moment dire stop, j'ai tout mes fichiers voulu.
C'est une sorte de concaténation que je demande.
Alors j'ai bien évidement cherché sur le net des éléments de réponse et voila ce que j'ai trouvé :
-Il est possible de programmer une Macro permettant à l'utilisateur de sélectionner un fichier dans une arborescence. J'ai testé j'y suis arrivé (et oui même moi lol)
-Il est possible de demander l'ouverture successive de plusieurs fichiers à la suite. Sauf que je ne suis pas arrivé à les mettre sur UNE SEULE feuille Excel ET à la suite les un des autres.
J'ai donc trouvé à travers le net des petits bouts de réponse particulièrement intéressant mais encore trop complexe pour moi. Certains code sont compréhensible de loin mais les fonctions et le langage bien trop compliqué pour que je puisse modifier moi même le code source.
Je ne pense pas que sa sois une mission impossible pour un expert de vba. De même je ne pense pas que cela prenne bien plus de 30 min pour coder tout sa.
Ce que je vous demande est alors un peu de votre temps pour m'aider sur ce projet. J'ai d'autres idées en tête avec cette Macro mais pour le moment je procède étape par étape. Si j'arrive à faire ce que je demande je serais bien assez content pour démarrer.
Pour terminer je fais donc un dernier rappel très concis :
-Je veux un fichier Excel avec un seul bouton qui est lié à une ou plusieurs Macro(s)
-Je veux pouvoir parcourir plusieurs fichiers dans une arborescence et concaténer les fichiers les un après les autres
Est possible ? Je le pense à 90%
Bien amicalement,
André
C'est mon premier post ici alors je ne sais pas trop si je suis au bon endroit. D'avance je m'excuse.
Je viens vous demander un peu d'aide (beaucoup en fait !). Je viens de découvrir les macros sous Excel. Je sais qu'il existe 2 manière de procéder : sois en programmant par code sois en enregistrant une macro action par action de manière automatique. Je suis donc vraiment novice.
Voila mon objectif :
Dans un dossier disponible sur le pc, j'enregistre plusieurs fichiers .txt (14 fichiers environs). Ces fichiers ont la particularité d'avoir TOUJOURS le même nombre de colonnes (5 colonnes) mais pas forcément le même nombre de lignes (de 0 à 3000 lignes).
Ci après je vous donne un exemple d'un fichier pour mieux voir.
FICHIER 1 :
0 2 4 9 2,2
3 6 7 1 5,6
FICHIER 2 :
3 0 2 3 10
3 2 4 7 89
2 1 1 3 0,01
3 4 1 3 2
Donc le nombre de colonnes est fixe, le nombre de lignes variable et le contenu est exclusivement du nombre.
Je peux avoir plusieurs fichiers de ce type avec plus de lignes. J'aimerais disposer d'un fichier Excel avec une seule Macro à l'intérieure. A partir de l'onglet Formulaire d'Excel j'aimerais insérer un gro bouton qui serait la seule interface avec l'utilisateur. Pour que sa sois simple. Jusque la j'ai réussi à trouver mon bonheur (facile pour vous ? Je sais lol)
La ou sa se corse... Lorsque que je clique sur ce bouton formulaire j'aimerais déclencher ma Macro qui me demande alors de sélectionner mon premier fichier qui se trouve dans un dossier quelconque du PC. Ensuite le contenu du fichier s'ouvre dans un NOUVEAU fichier Excel. Puis automatiquement la macro me demande de sélectionner le fichier suivant qui vas alors s'ouvrir dans le même fichier Excel précédant ET à la suite de l'autre.
La encore pour mieux comprendre je vous donne le résultat estompé.
FICHIER 3 :
0 2 4 9 2,2
3 6 7 1 5,6
3 0 2 3 10
3 2 4 7 89
2 1 1 3 0,01
3 4 1 3 2
La Macro doit permettre de stopper le processus d'importation des fichiers à un moment. C'est à dire si je veux importer 2 fichiers, et bien que je puisse à un moment dire stop, j'ai tout mes fichiers voulu.
C'est une sorte de concaténation que je demande.
Alors j'ai bien évidement cherché sur le net des éléments de réponse et voila ce que j'ai trouvé :
-Il est possible de programmer une Macro permettant à l'utilisateur de sélectionner un fichier dans une arborescence. J'ai testé j'y suis arrivé (et oui même moi lol)
-Il est possible de demander l'ouverture successive de plusieurs fichiers à la suite. Sauf que je ne suis pas arrivé à les mettre sur UNE SEULE feuille Excel ET à la suite les un des autres.
J'ai donc trouvé à travers le net des petits bouts de réponse particulièrement intéressant mais encore trop complexe pour moi. Certains code sont compréhensible de loin mais les fonctions et le langage bien trop compliqué pour que je puisse modifier moi même le code source.
Je ne pense pas que sa sois une mission impossible pour un expert de vba. De même je ne pense pas que cela prenne bien plus de 30 min pour coder tout sa.
Ce que je vous demande est alors un peu de votre temps pour m'aider sur ce projet. J'ai d'autres idées en tête avec cette Macro mais pour le moment je procède étape par étape. Si j'arrive à faire ce que je demande je serais bien assez content pour démarrer.
Pour terminer je fais donc un dernier rappel très concis :
-Je veux un fichier Excel avec un seul bouton qui est lié à une ou plusieurs Macro(s)
-Je veux pouvoir parcourir plusieurs fichiers dans une arborescence et concaténer les fichiers les un après les autres
Est possible ? Je le pense à 90%
Bien amicalement,
André
A voir également:
- Macro Excel pr concatener plusieurs fichiers
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Liste déroulante excel - Guide
- Formule moyenne excel plusieurs colonnes - Guide
- Concatener deux cellules excel - Guide
- Renommer plusieurs fichiers en même temps - Guide
2 réponses
personne pour m'aider un peu ?
D'après mes recherches j'ai réussi à faire ouvrir des fichiers en parcourant une arborescence mais je n'arrive pas à charger les données sur une seule feuille. C'est pas si simple pour moi.
Je suis sure que s'est possible. Mais la sa fait déjà tout une après midi de perdu à chercher pour rien...
Merci à ceux qui oseront m'aider un peu.
D'après mes recherches j'ai réussi à faire ouvrir des fichiers en parcourant une arborescence mais je n'arrive pas à charger les données sur une seule feuille. C'est pas si simple pour moi.
Je suis sure que s'est possible. Mais la sa fait déjà tout une après midi de perdu à chercher pour rien...
Merci à ceux qui oseront m'aider un peu.
Je vous joint ci-après 2 codes que j'ai trouvé sur Internet. Ils font presque ce que je veux mais pas tout à fait.
A tout ceux qui veulent m'aider, il ne s'agit plus de se prendre la tête à coder, mais à modifier légèrement un code existant. Donc encore plus facile et rapide.
Premier code :
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
Option Explicit
Dim TabFichiers() As String
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim n As Long, bFlagNomFeuille As Boolean
Dim iRow As Long, Cpt As Long, NbFichiers As Long, sNum As String, sNomAct As String
Const sNomFeuilleALire As String = "Material"
Const iRowDep As Long = 3
Const sNomFeuillesDatas As String = "Material"
Const TypeFichier As String = "xls"
Private Sub DispoBoutons()
Dim t As Range
With ShMaterial
.Activate
.Rows(1).RowHeight = 30.75
Set t = .Cells(1, 1)
With .Buttons("Bouton 1")
.Left = t.Left + 3
.Top = t.Top + 5
.Width = 100
.Height = Rows(1).RowHeight - 8
End With
With .Buttons("Bouton 2")
.Left = ShMaterial.Buttons("Bouton 1").Left + ShMaterial.Buttons("Bouton 1").Width + 5
.Top = ShMaterial.Buttons("Bouton 1").Top
.Width = 100
.Height = ShMaterial.Buttons("Bouton 1").Height
End With
End With
End Sub
Private Sub Entete()
Dim i As Long
Range("A" & iRowDep - 1 & ":Y" & iRowDep - 1).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Selection.AutoFilter
Range("A" & iRowDep - 1).Interior.ColorIndex = 44
Range("F" & iRowDep - 1).Interior.ColorIndex = 44
For i = 1 To 25
ShMaterial.Cells(iRowDep - 1, i) = NumCol2Lettre(i)
Next i
End Sub
Private Function ExistenceNomFeuille(sNomFichier As String, sNomFeuille As String) As Boolean
Dim Conn As Object
Dim Cat As Object
Dim Feuille As Object
Dim sNom As String
Set Conn = CreateObject("ADODB.Connection")
Set Cat = CreateObject("ADOX.Catalog")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sNomFichier & ";" & _
"Extended Properties=""Excel 8.0;"""
Set Cat.ActiveConnection = Conn
ExistenceNomFeuille = False
For Each Feuille In Cat.Tables
Select Case Right$(Feuille.Name, 1)
Case "$"
sNom = Left$(Feuille.Name, Len(Feuille.Name) - 1)
If sNom = sNomFeuille Then
ExistenceNomFeuille = True
Exit For
End If
Case "'"
sNom = Mid$(Feuille.Name, 2, Len(Feuille.Name) - 3)
If sNom = sNomFeuille Then
ExistenceNomFeuille = True
Exit For
End If
End Select
Next Feuille
Conn.Close
Set Cat = Nothing
Set Conn = Nothing
End Function
Private Sub Init()
iRow = iRowDep: Cpt = 0: NbFichiers = 0: n = 0: sNum = ""
ShMaterial.Cells.Clear
End Sub
Private Sub LectureFichiers()
Dim i As Long
For i = 1 To UBound(TabFichiers)
Lire TabFichiers(i)
Cpt = Cpt + 1
Next i
End Sub
Private Sub TestExistenceFeuilleDossier()
Dim i As Long, sNomFichier As String
Dim iMax As Long
iMax = UBound(TabFichiers)
bFlagNomFeuille = True
For i = LBound(TabFichiers) To UBound(TabFichiers)
bFlagNomFeuille = ExistenceNomFeuille(TabFichiers(i), sNomFeuilleALire)
If bFlagNomFeuille = False Then
Application.ScreenUpdating = True
sNomFichier = TabFichiers(i)
MsgBox sNomFeuilleALire & " n'existe pas dans " & vbCrLf & sNomFichier, vbOKOnly + vbCritical
Exit Sub
End If
Application.StatusBar = "Vérification existence : " & sNomFeuilleALire & " " & i & " / " & iMax
Next i
End Sub
Private Sub TestExistenceFeuille(ByVal sFichier As String)
Dim i As Long
bFlagNomFeuille = ExistenceNomFeuille(sFichier, sNomFeuilleALire)
If bFlagNomFeuille = False Then
Application.ScreenUpdating = True
MsgBox sNomFeuilleALire & " n'existe pas dans " & vbCrLf & sFichier, vbOKOnly + vbCritical
Exit Sub
End If
Application.StatusBar = "Vérification existence : " & sNomFeuilleALire & " " & Cpt & " / " & NbFichiers
End Sub
Private Sub Lire(ByVal sNomFichier As String)
Dim FSO As Object
Dim Fichier As String
Dim LastRow As Long
Dim Wkb As Workbook, sNomSh As String
Dim LastRowPaste As Long, i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Fichier = FSO.GetFileName(sNomFichier)
Application.DisplayAlerts = False
Set Wkb = Application.Workbooks.Open(sNomFichier, UpdateLinks:=xlUpdateLinksNever, ReadOnly:=True)
Application.DisplayAlerts = True
LastRow = Wkb.Sheets(sNomFeuilleALire).Range("A" & Rows.Count).End(xlUp).Row
LastRowPaste = iRow + LastRow - iRowDep
Wkb.Sheets(sNomFeuilleALire).Range("A3:Y" & LastRow).Copy
ThisWorkbook.Worksheets(ShMaterial.Name).Range("A" & iRow).PasteSpecial xlPasteValues
iRow = iRow + LastRow - 2
With Application
.StatusBar = "Lecture Fichiers : " & Cpt + 1 & " / " & NbFichiers
.CutCopyMode = False
End With
Wkb.Close False
Set FSO = Nothing
End Sub
Private Sub ListeFichiersDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Dossier = FSO.GetFolder(sChemin)
Fichier = Dir$(sChemin & "\*.*")
Do While Len(Fichier) > 0
sPath = sChemin & "\" & Fichier
If Fichier <> ThisWorkbook.Name And UCase(TypeFichier) = UCase(FSO.GetExtensionName(Fichier)) Then
NbFichiers = NbFichiers + 1
ReDim Preserve TabFichiers(1 To NbFichiers)
TabFichiers(NbFichiers) = sPath
End If
Fichier = Dir$()
Loop
If bInclureSousDossiers Then
For Each Dossier In Dossier.SubFolders
ListeFichiersDossier Dossier.Path, True
Next Dossier
End If
Set Dossier = Nothing
Set FSO = Nothing
End Sub
Private Sub MepFinale()
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
With ShMaterial
.Activate
.Range("C1").Select
End With
End Sub
Private Function NumCol2Lettre(ByVal NumCol As Long) As String
Dim i As Long, x As Long, s As String
Dim Max As Long
Max = Int(Log(CDbl(25 * (CDbl(NumCol) + 1))) / Log(26)) - 1
For i = Max To 0 Step -1
x = (26 ^ (i + 1) - 1) / 25 - 1
If NumCol > x Then
s = s & Chr(((NumCol - x - 1) \ 26 ^ i) Mod 26 + 65)
End If
Next i
NumCol2Lettre = s
End Function
Sub OuvertureFichiersMultiples()
Dim Fichier As Variant, i As Long
ChDir ThisWorkbook.Path
Fichier = Application.GetOpenFilename("Excel ,*.xls", 1, _
"Sélectionner un ou plusieurs fichier(s)", , True)
If TypeName(Fichier) = "Boolean" Then
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
ShMaterial.Range("C1").Select
Exit Sub
End If
QueryPerformanceCounter Dep
Init
DoEvents
Application.ScreenUpdating = False
NbFichiers = UBound(Fichier)
For i = 1 To NbFichiers
Cpt = Cpt + 1
TestExistenceFeuille Fichier(i)
If bFlagNomFeuille = False Then
MepFinale
Application.ScreenUpdating = True
Exit Sub
End If
Next i
Cpt = 0
For i = 1 To NbFichiers
Lire Fichier(i)
Cpt = Cpt + 1
Next i
Entete
MepFinale
QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
With Application
.ScreenUpdating = True
.StatusBar = "Terminé : Fichiers " & Cpt & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
End With
End Sub
Sub SelDossier()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path & "\"
.Title = "Dossier à traiter"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.ButtonName = "Sélection Dossier"
.Show
If .SelectedItems.Count > 0 Then
QueryPerformanceCounter Dep
Init
DoEvents
Application.ScreenUpdating = False
ListeFichiersDossier .SelectedItems(1), False
TestExistenceFeuilleDossier
If NbFichiers = 0 Or bFlagNomFeuille = False Then
MepFinale
Application.ScreenUpdating = True
Exit Sub
End If
LectureFichiers
Entete
MepFinale
QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
With Application
.ScreenUpdating = True
.StatusBar = "Terminé : Fichiers " & Cpt & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
End With
End If
ShMaterial.Range("C1").Select
End With
End Sub
------------------------------------------------------------------------------
Ci-après le deuxième code
------------------------------------------------------------------------------
Sub Test()
Dim fd As FileDialog, Chemin As String
Dim I As Long, Import As String, Tableau As Double
Cells.Clear
I = 1
Chemin = "TEST"
While Chemin <> ""
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Textes", "*.dat", 1
.FilterIndex = 1
If .Show = -1 Then
Chemin = .SelectedItems(1)
Else
GoTo Fin
End If
End With
Open Chemin For Input As #1
Do While Not EOF(1)
Line Input #1, Import
Range("A" & I & ":E" & I).Value = Split(Replace(Import, ",", "."), Chr(9))
I = I + 1
Loop
Close #1
Wend
Fin:
If I = 1 Then Exit Sub
Range("F1") = 1
Range("F1").Copy
Range("A1:E" & I - 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("F1").Clear
End Sub
Remarques : Le premier code ne permet d'ouvrir que des fichiers .xls (or je veux ouvrir des fichiers .dat et/ou .txt). Je veux enregistrer tous les fichiers dans une seule feuille Excel. Le premier code permet également d'ouvrir des dossiers mais sa ne m'intéresse pas. J'ai peur de supprimer une mauvaise partie du code.
Le deuxième code ne se compile pas suite à une erreur "Erreur de compilation : Type défini par l'utilisateur non défini". Cela concerne les premières lignes de code "Dim fd As FileDialog".
Des idées d'améliorations simples sur un des deux codes ?
A tout ceux qui veulent m'aider, il ne s'agit plus de se prendre la tête à coder, mais à modifier légèrement un code existant. Donc encore plus facile et rapide.
Premier code :
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
Option Explicit
Dim TabFichiers() As String
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim n As Long, bFlagNomFeuille As Boolean
Dim iRow As Long, Cpt As Long, NbFichiers As Long, sNum As String, sNomAct As String
Const sNomFeuilleALire As String = "Material"
Const iRowDep As Long = 3
Const sNomFeuillesDatas As String = "Material"
Const TypeFichier As String = "xls"
Private Sub DispoBoutons()
Dim t As Range
With ShMaterial
.Activate
.Rows(1).RowHeight = 30.75
Set t = .Cells(1, 1)
With .Buttons("Bouton 1")
.Left = t.Left + 3
.Top = t.Top + 5
.Width = 100
.Height = Rows(1).RowHeight - 8
End With
With .Buttons("Bouton 2")
.Left = ShMaterial.Buttons("Bouton 1").Left + ShMaterial.Buttons("Bouton 1").Width + 5
.Top = ShMaterial.Buttons("Bouton 1").Top
.Width = 100
.Height = ShMaterial.Buttons("Bouton 1").Height
End With
End With
End Sub
Private Sub Entete()
Dim i As Long
Range("A" & iRowDep - 1 & ":Y" & iRowDep - 1).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Selection.AutoFilter
Range("A" & iRowDep - 1).Interior.ColorIndex = 44
Range("F" & iRowDep - 1).Interior.ColorIndex = 44
For i = 1 To 25
ShMaterial.Cells(iRowDep - 1, i) = NumCol2Lettre(i)
Next i
End Sub
Private Function ExistenceNomFeuille(sNomFichier As String, sNomFeuille As String) As Boolean
Dim Conn As Object
Dim Cat As Object
Dim Feuille As Object
Dim sNom As String
Set Conn = CreateObject("ADODB.Connection")
Set Cat = CreateObject("ADOX.Catalog")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sNomFichier & ";" & _
"Extended Properties=""Excel 8.0;"""
Set Cat.ActiveConnection = Conn
ExistenceNomFeuille = False
For Each Feuille In Cat.Tables
Select Case Right$(Feuille.Name, 1)
Case "$"
sNom = Left$(Feuille.Name, Len(Feuille.Name) - 1)
If sNom = sNomFeuille Then
ExistenceNomFeuille = True
Exit For
End If
Case "'"
sNom = Mid$(Feuille.Name, 2, Len(Feuille.Name) - 3)
If sNom = sNomFeuille Then
ExistenceNomFeuille = True
Exit For
End If
End Select
Next Feuille
Conn.Close
Set Cat = Nothing
Set Conn = Nothing
End Function
Private Sub Init()
iRow = iRowDep: Cpt = 0: NbFichiers = 0: n = 0: sNum = ""
ShMaterial.Cells.Clear
End Sub
Private Sub LectureFichiers()
Dim i As Long
For i = 1 To UBound(TabFichiers)
Lire TabFichiers(i)
Cpt = Cpt + 1
Next i
End Sub
Private Sub TestExistenceFeuilleDossier()
Dim i As Long, sNomFichier As String
Dim iMax As Long
iMax = UBound(TabFichiers)
bFlagNomFeuille = True
For i = LBound(TabFichiers) To UBound(TabFichiers)
bFlagNomFeuille = ExistenceNomFeuille(TabFichiers(i), sNomFeuilleALire)
If bFlagNomFeuille = False Then
Application.ScreenUpdating = True
sNomFichier = TabFichiers(i)
MsgBox sNomFeuilleALire & " n'existe pas dans " & vbCrLf & sNomFichier, vbOKOnly + vbCritical
Exit Sub
End If
Application.StatusBar = "Vérification existence : " & sNomFeuilleALire & " " & i & " / " & iMax
Next i
End Sub
Private Sub TestExistenceFeuille(ByVal sFichier As String)
Dim i As Long
bFlagNomFeuille = ExistenceNomFeuille(sFichier, sNomFeuilleALire)
If bFlagNomFeuille = False Then
Application.ScreenUpdating = True
MsgBox sNomFeuilleALire & " n'existe pas dans " & vbCrLf & sFichier, vbOKOnly + vbCritical
Exit Sub
End If
Application.StatusBar = "Vérification existence : " & sNomFeuilleALire & " " & Cpt & " / " & NbFichiers
End Sub
Private Sub Lire(ByVal sNomFichier As String)
Dim FSO As Object
Dim Fichier As String
Dim LastRow As Long
Dim Wkb As Workbook, sNomSh As String
Dim LastRowPaste As Long, i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Fichier = FSO.GetFileName(sNomFichier)
Application.DisplayAlerts = False
Set Wkb = Application.Workbooks.Open(sNomFichier, UpdateLinks:=xlUpdateLinksNever, ReadOnly:=True)
Application.DisplayAlerts = True
LastRow = Wkb.Sheets(sNomFeuilleALire).Range("A" & Rows.Count).End(xlUp).Row
LastRowPaste = iRow + LastRow - iRowDep
Wkb.Sheets(sNomFeuilleALire).Range("A3:Y" & LastRow).Copy
ThisWorkbook.Worksheets(ShMaterial.Name).Range("A" & iRow).PasteSpecial xlPasteValues
iRow = iRow + LastRow - 2
With Application
.StatusBar = "Lecture Fichiers : " & Cpt + 1 & " / " & NbFichiers
.CutCopyMode = False
End With
Wkb.Close False
Set FSO = Nothing
End Sub
Private Sub ListeFichiersDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Dossier = FSO.GetFolder(sChemin)
Fichier = Dir$(sChemin & "\*.*")
Do While Len(Fichier) > 0
sPath = sChemin & "\" & Fichier
If Fichier <> ThisWorkbook.Name And UCase(TypeFichier) = UCase(FSO.GetExtensionName(Fichier)) Then
NbFichiers = NbFichiers + 1
ReDim Preserve TabFichiers(1 To NbFichiers)
TabFichiers(NbFichiers) = sPath
End If
Fichier = Dir$()
Loop
If bInclureSousDossiers Then
For Each Dossier In Dossier.SubFolders
ListeFichiersDossier Dossier.Path, True
Next Dossier
End If
Set Dossier = Nothing
Set FSO = Nothing
End Sub
Private Sub MepFinale()
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
With ShMaterial
.Activate
.Range("C1").Select
End With
End Sub
Private Function NumCol2Lettre(ByVal NumCol As Long) As String
Dim i As Long, x As Long, s As String
Dim Max As Long
Max = Int(Log(CDbl(25 * (CDbl(NumCol) + 1))) / Log(26)) - 1
For i = Max To 0 Step -1
x = (26 ^ (i + 1) - 1) / 25 - 1
If NumCol > x Then
s = s & Chr(((NumCol - x - 1) \ 26 ^ i) Mod 26 + 65)
End If
Next i
NumCol2Lettre = s
End Function
Sub OuvertureFichiersMultiples()
Dim Fichier As Variant, i As Long
ChDir ThisWorkbook.Path
Fichier = Application.GetOpenFilename("Excel ,*.xls", 1, _
"Sélectionner un ou plusieurs fichier(s)", , True)
If TypeName(Fichier) = "Boolean" Then
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
ShMaterial.Range("C1").Select
Exit Sub
End If
QueryPerformanceCounter Dep
Init
DoEvents
Application.ScreenUpdating = False
NbFichiers = UBound(Fichier)
For i = 1 To NbFichiers
Cpt = Cpt + 1
TestExistenceFeuille Fichier(i)
If bFlagNomFeuille = False Then
MepFinale
Application.ScreenUpdating = True
Exit Sub
End If
Next i
Cpt = 0
For i = 1 To NbFichiers
Lire Fichier(i)
Cpt = Cpt + 1
Next i
Entete
MepFinale
QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
With Application
.ScreenUpdating = True
.StatusBar = "Terminé : Fichiers " & Cpt & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
End With
End Sub
Sub SelDossier()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path & "\"
.Title = "Dossier à traiter"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.ButtonName = "Sélection Dossier"
.Show
If .SelectedItems.Count > 0 Then
QueryPerformanceCounter Dep
Init
DoEvents
Application.ScreenUpdating = False
ListeFichiersDossier .SelectedItems(1), False
TestExistenceFeuilleDossier
If NbFichiers = 0 Or bFlagNomFeuille = False Then
MepFinale
Application.ScreenUpdating = True
Exit Sub
End If
LectureFichiers
Entete
MepFinale
QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
With Application
.ScreenUpdating = True
.StatusBar = "Terminé : Fichiers " & Cpt & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
End With
End If
ShMaterial.Range("C1").Select
End With
End Sub
------------------------------------------------------------------------------
Ci-après le deuxième code
------------------------------------------------------------------------------
Sub Test()
Dim fd As FileDialog, Chemin As String
Dim I As Long, Import As String, Tableau As Double
Cells.Clear
I = 1
Chemin = "TEST"
While Chemin <> ""
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Textes", "*.dat", 1
.FilterIndex = 1
If .Show = -1 Then
Chemin = .SelectedItems(1)
Else
GoTo Fin
End If
End With
Open Chemin For Input As #1
Do While Not EOF(1)
Line Input #1, Import
Range("A" & I & ":E" & I).Value = Split(Replace(Import, ",", "."), Chr(9))
I = I + 1
Loop
Close #1
Wend
Fin:
If I = 1 Then Exit Sub
Range("F1") = 1
Range("F1").Copy
Range("A1:E" & I - 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("F1").Clear
End Sub
Remarques : Le premier code ne permet d'ouvrir que des fichiers .xls (or je veux ouvrir des fichiers .dat et/ou .txt). Je veux enregistrer tous les fichiers dans une seule feuille Excel. Le premier code permet également d'ouvrir des dossiers mais sa ne m'intéresse pas. J'ai peur de supprimer une mauvaise partie du code.
Le deuxième code ne se compile pas suite à une erreur "Erreur de compilation : Type défini par l'utilisateur non défini". Cela concerne les premières lignes de code "Dim fd As FileDialog".
Des idées d'améliorations simples sur un des deux codes ?