Automatiser "Text to column" en VBA.

[volex]

Bonjour,

Je dois faire 350 imports de fichiers *.txt dans excel demain matin.

J'ai fait une petite macro (avec l'enregistreur, je suis nul en VBA !!!) qui fait la manipulation mais j'aimerai eviter de repeter l'operation 350 fois !!!!

Actuellement la macro formatte les donnees (j'ouvre tout d'abord le fichier *txt dans excel et je copie les donnees brutes dans une page) et les copies sur une autre page, voir code ci-dessous :

Sub grandlivres()
'
' grandlivres Macro
'

Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Application.CutCopyMode = False

Range("A1").Select
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
(20, 1), Array(21, 1), Array(22, 1), Array(23, 1)), TrailingMinusNumbers:=True

Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Columns("R:R").Select
Selection.Delete Shift:=xlToLeft
Range("A1:U20000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Base").Select
Range("B2").Select
ActiveSheet.Paste
Range("F13").Select
End Sub



Tous mes fcihiers *.txt sont dans le meme repertoire (c:\a) et ils ont tous un mon different.

Y aurait-il un moyen que excel ouvre tous les fichiers 1 par 1, formatte les donnees et copie le resultat dans des pages distinctes ?
Ou meme des fichiers *.xls distincts.

Merci d'avance,


Alex

 

[Hippolite]

Re : Automatiser "Text to column" en VBA.

Bonjour,
Ton besoin est très proche de celui traité ici :
http://158839-macro-etendre-la-recherche-sur-un-repertoire
A+

 

[volex]

Re : Automatiser "Text to column" en VBA.

Salut,

Pas le temps de regarder, on va se repartir le boulot entre collegues !!!



Alex

 

[MJ13]

Re : Automatiser "Text to column" en VBA.

Bonjour Volex, Hippolite

Tu peux tester ces macros à adapter (difficulté niveau 2).

Sub SyntèseFichiers_TXT()
'Adaptation code de JB
  '[A1:AZ10000].Clear
  Sheets.Add
    ClasseurDest = ActiveWorkbook.Name
    FeuilDest = ActiveSheet.Name
    Set maitre = ActiveWorkbook
  Repertoire = ActiveWorkbook.Path
  'Stop
  nf = Dir(Repertoire & "\*.txt")  ' premier fichier
  Do While nf <> ""
    If nf <> ThisWorkbook.Name Then
      Workbooks.Open Filename:=Repertoire & "\" & nf
     Range("A1").Select
        Derl = ActiveCell.SpecialCells(xlLastCell).Row
                DerlDest = Workbooks(ClasseurDest).Sheets(FeuilDest).Range("A1").SpecialCells(xlLastCell).Row
   Range("A1", "A" & Derl).Resize(, 26).Copy Workbooks(ClasseurDest).Sheets(FeuilDest).Range("A" & DerlDest).Offset(1, 0)
                 ActiveWorkbook.Close False
    End If
    nf = Dir ' fichier suivant
  Loop
End Sub

Sub SyntèseFichiers_TXT_Feuilles_Distinctes()
'Adaptation code de JB
  '[A1:AZ10000].Clear
  Sheets.Add
    ClasseurDest = ActiveWorkbook.Name
    FeuilDest = ActiveSheet.Name
    Set maitre = ActiveWorkbook
  Repertoire = ActiveWorkbook.Path
  'Stop
  nf = Dir(Repertoire & "\*.txt")  ' premier fichier
  Do While nf <> ""
    If nf <> ThisWorkbook.Name Then
      Workbooks.Open Filename:=Repertoire & "\" & nf
     Range("A1").Select
        Derl = ActiveCell.SpecialCells(xlLastCell).Row
                DerlDest = Workbooks(ClasseurDest).Sheets(FeuilDest).Range("A1").SpecialCells(xlLastCell).Row
   Range("A1", "A" & Derl).Resize(, 26).Copy Workbooks(ClasseurDest).Sheets(FeuilDest).Range("A" & DerlDest).Offset(1, 0)
                ActiveWorkbook.Close False
        Sheets.Add
        FeuilDest = ActiveSheet.Name
    End If
    nf = Dir ' fichier suivant
  Loop
  Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub