excel - 导入多个txt文件错误的日期和数字格式

Question

我正在尝试将多个 txt 文件导入 excel。此代码运行良好，但它弄乱了日期和数字格式。例如，对于大于 1000 的数字，它会省略零。我尝试了另一篇文章中描述的解决方案：Excel VBA - Importing multiple txt files but not able to convert data to text format with FieldInfo for the columns that are shown this kind of format questions,（第18、62、63列， 64,65）但它仍然无法正常工作。这是我正在使用的原始代码。

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

更新 我还发现了一个实际上解决数据格式错误的代码，但它仅用于导入 1 个文件。我需要类似的东西，但要导入 39 个 txt 文件，它们都具有相同的结构：大约 70 列，除了 3 个是数字和 1 个日期外，大多数是字符串（最后这些会造成麻烦）。有什么帮助吗？提前致谢。

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

标签： excelvba

Answer 1

从文本文件中提取时，您的问题是您的数据类型。你需要改变你18, 2的18, 1

Number Format
1      Text
2      General
3      I think this means skip?
4      Date

因此，您需要将您的数据类型更改为您FieldInfo:=Array(Array(18, 2), Array(62, 2), Array(63, 2), Array(64, 2), Array(65, 2))想要的数据类型。文本最适合我认为7位以上的数字。使用日期作为您的日期列，但您需要检查它是否是正确的格式

所以如果下面所有的都是数字，最后一个是日期，它看起来像这样

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, 1), Array(62, 1), Array(63, 1), Array(64, 1), Array(65, 4)), TrailingMinusNumbers:=True
        .Sheets(1).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)