Импорт 100 текстовых файлов в Excel сразу

У меня есть этот макрос для массового импорта в файлах Excel с расширенными таблицами Excel + .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-файл имеет ту же структуру: заголовок, идентификатор, дата, createdBy, текст.

Макрос работает, но:

  • Я хочу, чтобы каждый файл был в строке (этот макрос отображает их в столбце)

Это превосходит их по экспорту как .csv для импорта на моем веб-сайте joomla с MySql

Большое спасибо за вашу помощь!

Вместо использования Excel для выполнения грязной работы я бы рекомендовал использовать массивы для выполнения всей операции. Приведенный ниже код занял 1 sec для обработки 300 файлов

LOGIC:

  1. Прокрутите каталог, в котором есть текстовые файлы
  2. Откройте файл и прочитайте его за один проход в массив, а затем закройте файл.
  3. Сохранять результаты в массиве temp
  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 

Большое спасибо за эту информацию. Я хотел импортировать только 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 
Давайте будем гением компьютера.