将超大文本文件导入 Excel 的 vba 代码

Question

我有一个包含 150 万行数据的文本文件 (.txt)。我想将数据（未格式化）导入 Excel（2007）。问题是 Excel 每个选项卡只能处理 1M 行。我设置了一个代码来逐行复制数据，但它一直停在第 594,139 行。我不知道为什么。

谁能帮我为以下内容创建 VBA 代码：

• 打开文本文件，一次复制 200,000 行数据。
• 将数据放入 Excel（未格式化）。
• 从文本文件（等）中获取接下来的 200,000 行，并将其放入 Excel 中的先前数据下方。
• 当 Excel 达到第 1,000,000 行时 - 设置新选项卡并继续将数据放入 Excel。

以上听起来很简单，但我当前的宏没有完成。

任何帮助将不胜感激，

以下是我的原始代码。我尝试按块（200,000 行）复制文本，但随后我逐行尝试。

Sub LargeFileImport()

  Dim ResultStr As String
  Dim FileName As String
  Dim FileNum As Integer
  Dim Counter As Double
  FileName = ThisWorkbook.Path & "\" & InputBox("Please enter the Text File's name, e.g. ifs_ytd_fut") & ".txt"
  If FileName = "" Then End
  FileNum = FreeFile()
  Open FileName For Input As #FileNum
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Dim mypath As String
  mypath = ThisWorkbook.Path
 Workbooks.Add template:=xlWorksheet
 ActiveWorkbook.SaveAs (mypath & "/Extract.xls")
 Application.DisplayAlerts = True
 Application.ScreenUpdating = False
 Counter = 1
  Range("A1").Select
 Do While Seek(FileNum) <= LOF(FileNum)
  Application.StatusBar = "Importing Row " & _
         Counter & " of text file " & FileName
  Line Input #FileNum, ResultStr
  If Left(ResultStr, 1) = "=" Then
         ActiveCell.Value = "'" & ResultStr
  Else
         ActiveCell.Value = ResultStr
  End If
  If ActiveCell.Row = 1000000 Then
       ActiveWorkbook.Sheets.Add After:=ActiveSheet
      Else
  ActiveCell.Offset(1, 0).Select
      End If
  Counter = Counter + 1
  Loop
  Close
  Application.StatusBar = False
  Application.ScreenUpdating = True
  End Sub

CK。

Answer 1

这样的东西应该适合你

Sub Tester()

Const LINES_PER_SHEET As Long = 500000
Dim ResultStr As String
Dim FileName As String
Dim FileNum
Dim Counter As Long, r As Long
Dim wbNew As Excel.Workbook
Dim arr()
Dim mypath As String

    mypath = ThisWorkbook.Path

    FileName = ThisWorkbook.Path & "\" & _
               InputBox("Please enter the Text File's name, e.g. ifs_ytd_fut") & ".txt"
    If FileName = "" Then Exit Sub

    FileNum = FreeFile()
    Open FileName For Input As #FileNum

    Set wbNew = Workbooks.Add(template:=xlWorksheet)
    wbNew.SaveAs (mypath & "/Extract.xls")

    Counter = 0
    r = 0

    ReDim arr(1 To LINES_PER_SHEET, 1 To 1)

    Do While Not EOF(FileNum)

        If Counter Mod 1000 = 0 Then
            Application.StatusBar = "Importing Row " & _
             Counter & " of text file " & FileName
        End If

        Counter = Counter + 1
        r = r + 1
        Line Input #FileNum, ResultStr
        If Left(ResultStr, 1) = "=" Then ResultStr = "'" & ResultStr

        arr(r, 1) = ResultStr
        If r = LINES_PER_SHEET Then
            ArrayToSheet wbNew, arr
            r = 0
        End If
    Loop

    If Counter Mod LINES_PER_SHEET > 0 Then ArrayToSheet wbNew, arr

    Close #FileNum
    Application.StatusBar = False


End Sub

Sub ArrayToSheet(wb As Workbook, ByRef arr)
    Dim r As Long
    r = UBound(arr, 1)
    With wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
        .Range("A1").Resize(r, 1).Value = arr
    End With
    ReDim arr(1 To r, 1 To 1)
End Sub