vba 一次将 100 个文本文件导入 Excel

Importing 100 text files into Excel at once

提问by JinSnow

I have this macro to bulk import in a excel spreadsheet 100+ .txt files contained in the same folder :

我有这个宏可以批量导入 excel 电子表格中包含在同一文件夹中的 100+ .txt 文件：

Sub QueryImportText()
    Dim sPath As String, sName As String
    Dim i As Long, qt As QueryTable
    With ThisWorkbook
        .Worksheets.Add After:= _
            .Worksheets(.Worksheets.Count)
    End With
    ActiveSheet.Name = Format(Now, "yyyymmdd_hhmmss")
    sPath = "C:\Users\TxtFiles\"
    sName = Dir(sPath & "*.txt")
    i = 0
    Do While sName <> ""
        i = i + 1
        Cells(1, i).Value = sName
        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & sPath & sName, Destination:=Cells(2, i))
            .Name = Left(sName, Len(sName) - 4)
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
        sName = Dir()
        For Each qt In ActiveSheet.QueryTables
            qt.Delete
        Next
    Loop
End Sub

Each .txt file has the same structure: title, ID, date, createdBy, text.

每个 .txt 文件具有相同的结构：标题、ID、日期、createdBy、文本。

The macro is working but :

宏正在运行，但是：

• I want each file to be in a row (this macro display them in column)

• 我希望每个文件都排成一行（这个宏在列中显示它们）

This excel will them by export as .csv to be imported in my joomla website with MySql

这个 excel 将它们导出为 .csv 以使用 MySql 导入我的 joomla 网站

Thanks a lot for your help!

非常感谢你的帮助！

回答by Siddharth Rout

Instead of using Excel to do the dirty work, I would recommend using Arrays to perform the entire operation. The below code took 1 secto process 300 files

我建议使用 Arrays 来执行整个操作，而不是使用 Excel 来完成繁琐的工作。下面的代码需要1 sec处理 300 个文件

LOGIC:

逻辑：

1. Loop through the directory which has text files
2. Open the file and read it in one go into an array and then close the file.
3. Store the results in a temp array
4. When all data is read, simply output the array to Excel Sheet

1. 循环遍历包含文本文件的目录
2. 打开文件并将其读入一个数组，然后关闭文件。
3. 将结果存储在临时数组中
4. 读取所有数据后，只需将数组输出到 Excel Sheet

CODE: (Tried and tested)

代码：（尝试和测试）

'~~> Change path here
Const sPath As String = "C:\Users\Siddharth Rout\Desktop\DeleteMelater\"

Sub Sample()
    Dim wb As Workbook
    Dim ws As Worksheet

    Dim MyData As String, tmpData() As String, strData() As String
    Dim strFileName As String

    '~~> Your requirement is of 267 files of 1 line each but I created 
    '~~> an array big enough to to handle 1000 files
    Dim ResultArray(1000, 3) As String

    Dim i As Long, n As Long

    Debug.Print "Process Started At : " & Now

    n = 1

    Set wb = ThisWorkbook

    '~~> Change this to the relevant sheet
    Set ws = wb.Sheets("Sheet1")

    strFileName = Dir(sPath & "\*.txt")

    '~~> Loop through folder to get the text files
    Do While Len(strFileName) > 0

        '~~> open the file in one go and read it into an array
        Open sPath & "\" & strFileName For Binary As #1
        MyData = Space$(LOF(1))
        Get #1, , MyData
        Close #1
        strData() = Split(MyData, vbCrLf)

        '~~> Collect the info in result array
        For i = LBound(strData) To UBound(strData)
            If Len(Trim(strData(i))) <> 0 Then
                tmpData = Split(strData(i), ",")

                ResultArray(n, 0) = Replace(tmpData(0), Chr(34), "")
                ResultArray(n, 1) = Replace(tmpData(1), Chr(34), "")
                ResultArray(n, 2) = Replace(tmpData(2), Chr(34), "")
                ResultArray(n, 3) = Replace(tmpData(3), Chr(34), "")

                n = n + 1
            End If
        Next i

        '~~> Get next file
        strFileName = Dir
    Loop

    '~~> Write the array to the Excel Sheet
    ws.Range("A1").Resize(UBound(ResultArray), _
    UBound(Application.Transpose(ResultArray))) = ResultArray

    Debug.Print "Process ended At : " & Now
End Sub

回答by Krishnakumar AP

Thanks a lot for this information. I wanted to import only 4th column of my data file for that I had to put bit modification as follows

非常感谢您提供此信息。我只想导入我的数据文件的第 4 列，因为我不得不按如下方式进行位修改

 Sub QueryImportText()
    Dim sPath As String, sName As String
    Dim i As Long, qt As QueryTable
    With ThisWorkbook
        .Worksheets.Add After:= _
            .Worksheets(.Worksheets.Count)
    End With
    ActiveSheet.Name = Format(Now, "yyyymmdd_hhmmss")
    sPath = "C:\Users\TxtFiles\"
    sName = Dir(sPath & "*.txt")
    i = 0
    Do While sName <> ""
        i = i + 1
        Cells(1, i).Value = sName
        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & sPath & sName, Destination:=Cells(2, i))
            .Name = Left(sName, Len(sName) - 4)
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False,
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(9,9,9,1) <---------(here)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
        sName = Dir()
        For Each qt In ActiveSheet.QueryTables
            qt.Delete
        Next
    Loop
End Sub