Macro Excel pr concatener plusieurs fichiers
SERIEUXETCOOL
Messages postés
336
Date d'inscription
dimanche 3 avril 2011
Statut
Membre
Dernière intervention
12 juin 2012
-
3 avril 2011 à 18:10
SERIEUXETCOOL Messages postés 336 Date d'inscription dimanche 3 avril 2011 Statut Membre Dernière intervention 12 juin 2012 - 6 avril 2011 à 11:49
SERIEUXETCOOL Messages postés 336 Date d'inscription dimanche 3 avril 2011 Statut Membre Dernière intervention 12 juin 2012 - 6 avril 2011 à 11:49
A voir également:
- Macro Excel pr concatener plusieurs fichiers
- Arctan excel - Forum VBA Office (Excel, Word ...)
- Copier macro excel - Forum VBA Office (Excel, Word ...)
- Les fonctions " racines niemmes " et " arctan "et "arccos " et "arcsin" - Forum Visual Basic
- Tangente et arctangente ✓ - Forum C++ & C++ .NET
- Macro excel copier coller cellule dans une autre feuille ✓ - Forum Visual Basic
8 réponses
SERIEUXETCOOL
Messages postés
336
Date d'inscription
dimanche 3 avril 2011
Statut
Membre
Dernière intervention
12 juin 2012
1
4 avril 2011 à 11:42
4 avril 2011 à 11:42
Vraiment personne pour m'apporter un peu d'aide sur ces fonctions ?
Je sais que l'on peut parcourir une arborescence pour ouvrir un ou plusieurs fichiers .txt.
Je sais également que l'on peut copier le contenu du fichier texte ouvert et coller ce contenu dans la même feuille excel.
Alors comment assossier tout sa en un seul code vba ?
Merci à ceux qui prendront le tps de me lire.
André
Je sais que l'on peut parcourir une arborescence pour ouvrir un ou plusieurs fichiers .txt.
Je sais également que l'on peut copier le contenu du fichier texte ouvert et coller ce contenu dans la même feuille excel.
Alors comment assossier tout sa en un seul code vba ?
Merci à ceux qui prendront le tps de me lire.
André
SERIEUXETCOOL
Messages postés
336
Date d'inscription
dimanche 3 avril 2011
Statut
Membre
Dernière intervention
12 juin 2012
1
4 avril 2011 à 15:29
4 avril 2011 à 15:29
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 ?
cs_pacadebord
Messages postés
113
Date d'inscription
lundi 31 mars 2003
Statut
Membre
Dernière intervention
19 décembre 2011
2
5 avril 2011 à 12:22
5 avril 2011 à 12:22
Salut,
Tu compiles quoi ? J'ai peur de ne pas bien comprendre. Tu es sous vba EXCEL ou sous VB6 ?
Dans le code sus nommé, il y a "à boire et à manger". Les éléments dont tu as besoin sont là, avec plein d'autres inutiles.
Pac
Tu compiles quoi ? J'ai peur de ne pas bien comprendre. Tu es sous vba EXCEL ou sous VB6 ?
Dans le code sus nommé, il y a "à boire et à manger". Les éléments dont tu as besoin sont là, avec plein d'autres inutiles.
Pac
SERIEUXETCOOL
Messages postés
336
Date d'inscription
dimanche 3 avril 2011
Statut
Membre
Dernière intervention
12 juin 2012
1
5 avril 2011 à 12:55
5 avril 2011 à 12:55
Bonjour,
Je suis sous vba Excel. C'est une macro pour Excel que j'aimerais faire.
J'ai réussi à adapter le code à mon besoin finalement (avec un peu d'aide tout de même reçue sur un autre forum). Voici ci-après le code en question. Il s'agit de la dernière version en date et qui fonctionne très bien :
Sub Test2()
Dim Chemin As String, Valeur As Integer, N As Integer
Dim I As Long, Import As String, Tableau As Double
Application.ScreenUpdating = False ' Désactive l'affichage
Cells.Clear ' Vide la feuille
I = 1 ' Initialise la première ligne
Chemin = "TEST" ' Pour que la boucle ne s'arrête pas tout de suite
While Chemin <> "" ' Tant que Chemin n'est pas vide
Chemin = Application.GetOpenFilename("Texte, *.dat") ' Boite de dialogue
If InStr(Chemin, "") = 0 Then ' Si Chemin n'a pas de \ donc que l'opérateur a fait annuler
GoTo Fin ' Va à l'étiquette Fin:
End If ' Fin du test
Valeur = Application.InputBox("Valeur à reporter :", "3ème colonne", , , , , , 1) 'Boite de dialogue
Open Chemin For Input As #1 ' Ouvre un fichier en lecture
Do While Not EOF(1) ' Tant qu'on est pas à la dernière ligne
Line Input #1, Import ' Lit la ligne et la stocke dans Import
Range("A" & I & ":E" & I).Value = Split(Replace(Import, ",", "."), Chr(9))
' Copie dans la ligne I colonnes A à E la ligne importée où les "," sont remplacées par des "."
' et Split crée un tableau en fonction des tabulations (Chr(9))
' C'est là qu'on pourrait faire appel aux 2 dernières valeurs du tableau, mais ce serait plus lourd
Range("F" & I).Value = Valeur
I = I + 1 ' On augmente le N° de la ligne
Loop ' On boucle dans le fichier
Close #1 ' On ferme le fichier
Wend ' On boucle sur l'ouverture de fichier
Fin: ' Etiquette pour quand on sort de la boucle
If I = 1 Then Exit Sub ' Si on a pas importer de fichier, on quitte la Sub
' Le problème, c'est que le Split envoie des nombres au format texte, d'où le traitement complémentaire
Range("F1") = 1 ' Met 1 en F1
Range("F1").Copy ' Copie F1
Range("A1:E" & I - 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
' Collage spécial en multiplication par 1 qui transforme les valeurs textes en nombres
Application.CutCopyMode = False ' Désactive la sélection du copier
Range("F1").Clear ' Ote le 1 en F1
Range("A:C").Delete ' Supprime les 3 colonnes
N = Range("A65536").End(xlUp).Row 'Récupère le nombre total de lignes
For I = N To 1 Step -1
If Cells(I, 1) > 300 Or Cells(I, 1) < 50 Then Rows(I).Delete 'Permet d'encadrer la table
Next I
Application.ScreenUpdating = True ' Rétablit l'affichage
End Sub
Pour rappel aux nouveaux visiteurs, ce code permet d'importer les données contenues dans un fichier .dat et de les coller sur une feuille Excel. On peut ouvrir plusieurs Fichiers .dat et les données sont collées les unes à la suite des autres (fonction concaténer) sur la même feuille Excel.
De plus la marco permet à l'utilisateur de remplir une colonne par une valeur particulière et ce pour chaque fichier importé. Pour conclure, lors de l'import des données, on supprime un certains de nombre de lignes et de colonnes qui sont jugées inutiles. C'est la mise en forme de la table.
L'opération qu'il me reste à effectuer une fois tous les fichiers importés et ma table bien mise en forme, est un tableau croisé dynamique puis un graphe 3D (de surface).
Pour ce faire je vais enregistrer une nouvelle macro pas à pas de manière à obtenir une première version de code vba. Le souci que je vois venir réside dans le fait que mon graphe seras associé à une certaines plage de valeurs, pour un nom de fichier...
Bref quand je déciderais de coller mon bout de code qui fonctionne bien dans mon code source je sens que sa ne vas pas coïncider pour n'importe quel fichier importé si ma table change de nom ou de nombre de lignes...
Je vais tester un premier code en enregistrant une macro pas à pas. Je vais voir ce que j'en sors. J'aurais sans doute besoin d'un peu d'aide pour généraliser mon code avec le code source. Mais avant d'avoir des réponses je veux chercher un peu.
Je vous tiens au courant, sa devrait aller vite.
André
Je suis sous vba Excel. C'est une macro pour Excel que j'aimerais faire.
J'ai réussi à adapter le code à mon besoin finalement (avec un peu d'aide tout de même reçue sur un autre forum). Voici ci-après le code en question. Il s'agit de la dernière version en date et qui fonctionne très bien :
Sub Test2()
Dim Chemin As String, Valeur As Integer, N As Integer
Dim I As Long, Import As String, Tableau As Double
Application.ScreenUpdating = False ' Désactive l'affichage
Cells.Clear ' Vide la feuille
I = 1 ' Initialise la première ligne
Chemin = "TEST" ' Pour que la boucle ne s'arrête pas tout de suite
While Chemin <> "" ' Tant que Chemin n'est pas vide
Chemin = Application.GetOpenFilename("Texte, *.dat") ' Boite de dialogue
If InStr(Chemin, "") = 0 Then ' Si Chemin n'a pas de \ donc que l'opérateur a fait annuler
GoTo Fin ' Va à l'étiquette Fin:
End If ' Fin du test
Valeur = Application.InputBox("Valeur à reporter :", "3ème colonne", , , , , , 1) 'Boite de dialogue
Open Chemin For Input As #1 ' Ouvre un fichier en lecture
Do While Not EOF(1) ' Tant qu'on est pas à la dernière ligne
Line Input #1, Import ' Lit la ligne et la stocke dans Import
Range("A" & I & ":E" & I).Value = Split(Replace(Import, ",", "."), Chr(9))
' Copie dans la ligne I colonnes A à E la ligne importée où les "," sont remplacées par des "."
' et Split crée un tableau en fonction des tabulations (Chr(9))
' C'est là qu'on pourrait faire appel aux 2 dernières valeurs du tableau, mais ce serait plus lourd
Range("F" & I).Value = Valeur
I = I + 1 ' On augmente le N° de la ligne
Loop ' On boucle dans le fichier
Close #1 ' On ferme le fichier
Wend ' On boucle sur l'ouverture de fichier
Fin: ' Etiquette pour quand on sort de la boucle
If I = 1 Then Exit Sub ' Si on a pas importer de fichier, on quitte la Sub
' Le problème, c'est que le Split envoie des nombres au format texte, d'où le traitement complémentaire
Range("F1") = 1 ' Met 1 en F1
Range("F1").Copy ' Copie F1
Range("A1:E" & I - 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
' Collage spécial en multiplication par 1 qui transforme les valeurs textes en nombres
Application.CutCopyMode = False ' Désactive la sélection du copier
Range("F1").Clear ' Ote le 1 en F1
Range("A:C").Delete ' Supprime les 3 colonnes
N = Range("A65536").End(xlUp).Row 'Récupère le nombre total de lignes
For I = N To 1 Step -1
If Cells(I, 1) > 300 Or Cells(I, 1) < 50 Then Rows(I).Delete 'Permet d'encadrer la table
Next I
Application.ScreenUpdating = True ' Rétablit l'affichage
End Sub
Pour rappel aux nouveaux visiteurs, ce code permet d'importer les données contenues dans un fichier .dat et de les coller sur une feuille Excel. On peut ouvrir plusieurs Fichiers .dat et les données sont collées les unes à la suite des autres (fonction concaténer) sur la même feuille Excel.
De plus la marco permet à l'utilisateur de remplir une colonne par une valeur particulière et ce pour chaque fichier importé. Pour conclure, lors de l'import des données, on supprime un certains de nombre de lignes et de colonnes qui sont jugées inutiles. C'est la mise en forme de la table.
L'opération qu'il me reste à effectuer une fois tous les fichiers importés et ma table bien mise en forme, est un tableau croisé dynamique puis un graphe 3D (de surface).
Pour ce faire je vais enregistrer une nouvelle macro pas à pas de manière à obtenir une première version de code vba. Le souci que je vois venir réside dans le fait que mon graphe seras associé à une certaines plage de valeurs, pour un nom de fichier...
Bref quand je déciderais de coller mon bout de code qui fonctionne bien dans mon code source je sens que sa ne vas pas coïncider pour n'importe quel fichier importé si ma table change de nom ou de nombre de lignes...
Je vais tester un premier code en enregistrant une macro pas à pas. Je vais voir ce que j'en sors. J'aurais sans doute besoin d'un peu d'aide pour généraliser mon code avec le code source. Mais avant d'avoir des réponses je veux chercher un peu.
Je vous tiens au courant, sa devrait aller vite.
André
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
cs_pacadebord
Messages postés
113
Date d'inscription
lundi 31 mars 2003
Statut
Membre
Dernière intervention
19 décembre 2011
2
5 avril 2011 à 16:06
5 avril 2011 à 16:06
Pour le fun :
Pac
Dim Fichiers As Variant
Dim i As Integer
Dim wb As Workbook
Dim donnees As Range
Fichiers = Application.GetOpenFilename("Fichiers dat (*.dat), *.dat", , , , True)
If IsArray(Fichiers) = True Then
Application.ScreenUpdating = False
For i = LBound(Fichiers) To UBound(Fichiers)
Workbooks.OpenText Filename:=Fichiers(i), DataType:=xlDelimited, Tab:=True
Set wb = ActiveWorkbook
Set donnees = wb.Sheets(1).[A1].CurrentRegion
donnees.Copy ThisWorkbook.Sheets(1).[A65536].End(xlUp)(2)
wb.Close
Set donnees = Nothing
Set wb = Nothing
Next i
Application.ScreenUpdating = True
End If
Pac
SERIEUXETCOOL
Messages postés
336
Date d'inscription
dimanche 3 avril 2011
Statut
Membre
Dernière intervention
12 juin 2012
1
5 avril 2011 à 23:08
5 avril 2011 à 23:08
Oui en effet Pac, ton code fonctionne très bien lui aussi. Il a le mérite d'être un peu plus court que le miens.
A noter que ton code ne permet pas à l'utilisateur de saisir une valeur et de la faire mettre dans une colonne sur autant de ligne que le fichier importé en contient. Ton code ne permet pas non plus de supprimer les 3 premières colonnes qui sont inutiles ni même d'encadrer la table par deux valeur [50;300] sur la colonne numéro 1. Mais cela je sais le faire, donc pas grave. Sa ne change pas le problème que j'ai toujours.
Cela rajoute un peu de lignes de codes ce qui au final reviens grosomodo au même code que j'ai. L'approche est différente, l'idée est bonne car c'est plus simple de compréhension avec ton code Pac. Donc à poursuivre.
Malheureusement, ton code me permet de faire la même chose que mon propre code. C'est à dire de produire une table avec un nombre de colonnes fixes et un nombre de lignes variables suivant ce que l'utilisateur importe.
Moi ce qui m'intéresse maintenant (et c'est la ou je bloque depuis ce matin !!!) c'est de créer un Tableau Croisé Dynamique puis un graphe 3D (de surface) de cette table.
La je n'y parviens pas car la table évolue et je n'arrive pas à faire suivre mon tableau dynamique en fonction de la table dynamique créée par l'utilisateur.
Merci Pac
A noter que ton code ne permet pas à l'utilisateur de saisir une valeur et de la faire mettre dans une colonne sur autant de ligne que le fichier importé en contient. Ton code ne permet pas non plus de supprimer les 3 premières colonnes qui sont inutiles ni même d'encadrer la table par deux valeur [50;300] sur la colonne numéro 1. Mais cela je sais le faire, donc pas grave. Sa ne change pas le problème que j'ai toujours.
Cela rajoute un peu de lignes de codes ce qui au final reviens grosomodo au même code que j'ai. L'approche est différente, l'idée est bonne car c'est plus simple de compréhension avec ton code Pac. Donc à poursuivre.
Malheureusement, ton code me permet de faire la même chose que mon propre code. C'est à dire de produire une table avec un nombre de colonnes fixes et un nombre de lignes variables suivant ce que l'utilisateur importe.
Moi ce qui m'intéresse maintenant (et c'est la ou je bloque depuis ce matin !!!) c'est de créer un Tableau Croisé Dynamique puis un graphe 3D (de surface) de cette table.
La je n'y parviens pas car la table évolue et je n'arrive pas à faire suivre mon tableau dynamique en fonction de la table dynamique créée par l'utilisateur.
Merci Pac
cs_pacadebord
Messages postés
113
Date d'inscription
lundi 31 mars 2003
Statut
Membre
Dernière intervention
19 décembre 2011
2
6 avril 2011 à 11:32
6 avril 2011 à 11:32
Bonjour,
Le code proposé est le code généralement constaté en cherchant sur le net. Si l'on s'en tient à ta demande initiale, je pense que tu peux déclarer le post comme "résolu" et en ouvrir un autre pour ton projet de création de graphe 3d.
N'hésite pas à indenter et aérer ton code pour qu'il soit plus lisible pour les autres. Utilise la balise "code" (boutons dans la boîte "votre message") pour borner tes lignes de code.
Sois brefs dans tes commentaires, tu peux passer par la messagerie perso pour développer.
J'en oublie, le reste est sur le règlement
Pac
Le code proposé est le code généralement constaté en cherchant sur le net. Si l'on s'en tient à ta demande initiale, je pense que tu peux déclarer le post comme "résolu" et en ouvrir un autre pour ton projet de création de graphe 3d.
N'hésite pas à indenter et aérer ton code pour qu'il soit plus lisible pour les autres. Utilise la balise "code" (boutons dans la boîte "votre message") pour borner tes lignes de code.
Sois brefs dans tes commentaires, tu peux passer par la messagerie perso pour développer.
J'en oublie, le reste est sur le règlement
Pac
SERIEUXETCOOL
Messages postés
336
Date d'inscription
dimanche 3 avril 2011
Statut
Membre
Dernière intervention
12 juin 2012
1
6 avril 2011 à 11:49
6 avril 2011 à 11:49
Merci Pac pour tous tes conseils. En effet on s'éloigne maintenant un peu de ma demande originel. Et je peux classer ce post comme résolu... Je trouve pas l'option ? Ni même la balise "code" dont tu parles ???
Sinon je vais ouvrir un autre post. C'est une bonne remarque.
Encore merci pour ton aide Pac. C'est sympa et sa mérite de le souligner.
Bonne journée,
André
Sinon je vais ouvrir un autre post. C'est une bonne remarque.
Encore merci pour ton aide Pac. C'est sympa et sa mérite de le souligner.
Bonne journée,
André
