2 回答

• 9

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

  LOGIC:

  • 循环遍历包含文本文件的目录

  • 打开文件并将其读入一个数组，然后关闭该文件 .

  • 将结果存储在临时数组中

  • 读取所有数据后，只需将数组输出到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
  

  回复于 2024-04-26T14:19:51+08:00
• 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
  

  回复于 2024-04-26T14:19:51+08:00