2

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

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

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

宏正在工作，但是：

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

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

非常感谢你的帮助！

4

2 回答 2

9

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

逻辑：

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

代码：（经过试验和测试）

'~~> 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
于 2013-10-16T20:01:41.327 回答
0

非常感谢您提供这些信息。我只想导入我的数据文件的第 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
于 2016-02-16T06:57:17.803 回答