bonjour à tous
Une autre solution
Trouvée ici:
http://www.erlandsendata.no/english/index.php?d=envbadacimportadotxtws
Sub CreateNewWorkbookFromTextFile(strFolder As String, strTextFile As String)
' use like this: CreateNewWorkbookFromTextFile 'C:\\Temp', 'TextFileName.txt'
Dim cn As ADODB.Connection, rs As ADODB.Recordset, rsItems As ADODB.Recordset
Dim wb As Workbook, ws As Worksheet, i As Long, f As Long, strSQL As String
If Len(strFolder) = 0 Then Exit Sub
If Len(strTextFile) = 0 Then Exit Sub
Set cn = New ADODB.Connection
On Error Resume Next
cn.Open 'Driver={Microsoft Text Driver (*.txt; *.csv)};' & _
'Dbq=' & strFolder & ';' & _
'Extensions=asc,csv,tab,txt;'
On Error GoTo 0
If cn.State <> adStateOpen Then Exit Sub
' get all unique items from one field
Set rsItems = New ADODB.Recordset
strSQL = 'select distinct ITEM1 from ' & strTextFile
On Error Resume Next
rsItems.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
On Error GoTo 0
If rsItems.State <> adStateOpen Then ' did not find anything
Set rsItems = Nothing
cn.Close
Set cn = Nothing
Exit Sub
End If
Application.ScreenUpdating = False
' create a new workbook
Set wb = Workbooks.Add
i = 0
Do While Not rsItems.EOF ' for each unique field item
Application.StatusBar = 'Reading data for ' & rsItems(0).Value & '...'
i = i + 1
strSQL = 'select * from ' & strTextFile & ' where ITEM1 = '' & rsItems(0).Value & '''
Set rs = New ADODB.Recordset
On Error Resume Next
rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
On Error GoTo 0
If rs.State = adStateOpen Then
Application.StatusBar = 'Writing data for ' & rsItems(0).Value & '...'
With wb
If i > .Worksheets.Count Then ' add a new worksheet
.Worksheets.Add After:=.Worksheets(.Worksheets.Count)
End If
With .Worksheets(i) ' populate the item worksheet
' write field headings
For f = 0 To rs.Fields.Count - 1
.Range('A1').Offset(0, f).Formula = rs.Fields(f).Name
Next f
.Rows(1).Font.Bold = True
' write data records
.Range('A2').CopyFromRecordset rs, .Rows.Count - 1, Columns.Count
.Columns('A:IV').AutoFit
End With
End With
rs.Close
End If
Set rs = Nothing
rsItems.MoveNext
Application.StatusBar = False
DoEvents
Loop
rsItems.Close
Set rsItems = Nothing
cn.Close
Set cn = Nothing
wb.Worksheets(1).Activate
Set wb = Nothing
Application.ScreenUpdating = True
End Sub
