100個導入文本文件導入Excel一次

Question

我有這樣的宏批量導入的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 

每個.txt文件具有相同的結構： 標題，ID，日期，createdBy，文本。

宏是工作，但：

• 我希望每個文件是在一個行（列這個宏顯示它們）

這個Excel將他們由出口爲.csv是用MySql在我的joomla網站導入

非常感謝您的幫助！

Answer 1

而不是使用Excel來做骯髒的工作，我會建議使用數組來執行整個操作。下面的代碼把1 sec處理300個文件

LOGIC：

1. 遍歷具有文本文件
2. 打開文件，並在一個閱讀它的目錄去到一個數組，然後關閉文件。
3. 商店的結果在一個臨時陣列
4. 當讀取的所有數據，簡單地輸出該陣列Excel工作表

CODE：（屢試不爽）

'~~> 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 

Answer 2

由於一個很多這個信息。我想只導入我的數據文件的第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