I'm trying to import multiple txt files into excel. This code is working perfectly but it messes up date and number formats. For instance, it is omitting zeros for numbers higher than 1000. I tried the solution described in this other post: Excel VBA - Importing multiple txt files but not able to convert data to text format with FieldInfo for the columns that are showing this kind of format problems, (which are columns 18,62,63,64,65) but it is still not working. Here the original code I'm using.
Sub Extract()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim sDelimiter As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
sDelimiter = "|"
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
Set wkbAll = Application.ActiveWorkbook
x = 1
With Workbooks.Open(Filename:=FilesToOpen(x))
.Worksheets(1).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar:="|", FieldInfo:=Array(Array(18, 2), Array(62, 2), Array(63, 2), Array(64, 2), Array(65, 2)), TrailingMinusNumbers:=True
.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Close False
End With
x = x + 1
While x <= UBound(FilesToOpen)
With Workbooks.Open(Filename:=FilesToOpen(x))
.Worksheets(1).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=sDelimiter, FieldInfo:=Array(Array(18, 2), Array(62, 2), Array(63, 2), Array(64, 2), Array(65, 2)), TrailingMinusNumbers:=True
.Sheets(1).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End With
x = x + 1
Wend
wkbAll.Save
ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
UPDATE I also found a code which actually solves the data format error, but it is just for importing 1 file. I would need sth similar but for importing 39 txt files, all of them with the same structure: around 70 columns , most of them string except for 3 which are number and 1 date (these last ones are causing trouble). Any help? Thanks in advance.
Sub importCSV()
Dim ans As Integer:
ans = MsgBox("Click OK then select the file to import " & vbNewLine & "Data will be imported at position of active cell", vbOKCancel)
If ans = vbCancel Then
GoTo exitpoint
End If
'data will be imported at position of active cell as first data element
Dim ColumnsType() As Variant
strFilepath = Application.GetOpenFilename() 'prompt user for filepath of import file
If strFilepath = False Then Exit Sub
Dim intFileNo As Integer
Dim nCol As Long
Dim strLine As String
Dim varColumnFormat As Variant
Dim varTemp As Variant
' Read first line of file to figure out how many columns there are
intFileNo = FreeFile()
Open strFilepath For Input As #intFileNo
Line Input #intFileNo, strLine
Close #intFileNo
varTemp = Split(strLine, ",")
nCol = UBound(varTemp)
ReDim varColumnFormat(0 To nCol)
' get the columns to import as Text from user
Dim textit() As String
textit = Split(InputBox("Enter columns to format as Text (e.g 1,3,5)" & Chr(10) & Chr(10) & "Or OK/Cancel to use file definition"), ",")
ub = UBound(textit)
If ub = -1 Then 'if nothing entered, promp for file for column formats
Dim strFilename2 As String: strFilename2 = Application.GetOpenFilename()
If strFilename2 = "" Or strFilename2 = "False" Then
MsgBox "No column Types have been entered." & Chr(10) & "Exiting Sub.", vbExclamation
Exit Sub
End If
Dim strFileContent As String
Dim iFile As Integer: iFile = FreeFile
Open strFilename2 For Input As #iFile
strFileContent = Input(LOF(iFile), iFile)
Close #iFile
textit = Split(strFileContent, ",")
ub = UBound(textit)
If ub < nCol Then 'confirm there are enough column denoted in the file
MsgBox "There are too few columns denoted in your column format file." & Chr(10) & "Exiting Sub.", vbExclamation
Exit Sub
End If
For i = 0 To nCol 'assing the file values to the column format array
varColumnFormat(i) = Int(textit(i))
Next
Else 'assign the entered columns a Text format value in the column format array
Dim uBi As Integer
uBi = 0
For i = 0 To nCol
If i + 1 = textit(uBi) Then
varColumnFormat(i) = xlTextFormat
uBi = WorksheetFunction.Min(uBi + 1, ub)
Else
varColumnFormat(i) = xlGeneralFormat
End If
Next
End If
With ActiveWorkbook.ActiveSheet.QueryTables.Add(Connection:="TEXT;" & strFilepath, Destination:=ActiveCell) 'creates the query to import the CSV. All following lines are properties of this
.PreserveFormatting = False
.RefreshStyle = xlOverwriteCells
.AdjustColumnWidth = True
.TextFileParseType = xlDelimited
.TextFileOtherDelimiter = Application.International(xlListSeparator) 'uses system setting => EU countries = ';' and US = ','
.TextFileColumnDataTypes = varColumnFormat 'set column data types as input by user
.Refresh BackgroundQuery:=False 'this is neccesary so a second import can be done
End With
ActiveWorkbook.ActiveSheet.QueryTables(1).Delete 'deletes the query
MsgBox "Date Import Done!"
exitpoint:
End Sub
