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

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

请任何人帮助我创建以下VBA代码：

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

上述内容听起来很简单，但我当前的宏尚未完成

任何帮助都将不胜感激

下面是我的原始代码。我试图按块（200000行）复制文本，但随后我尝试逐行复制

子大文件导入（）

Dim ResultStr作为字符串
将文件名设置为字符串
Dim FileNum作为整数
双色暗计数器
FileName=thispoolk.Path&“\”InputBox（“请输入文本文件的名称，例如ifs\u ytd\u fut”）&“.txt”
如果FileName=”“，则结束
FileNum=FreeFile（）
打开文件名作为#FileNum输入
Application.ScreenUpdating=False
Application.DisplayAlerts=False
将mypath设置为字符串
mypath=ThisWorkbook.Path
工作簿。添加模板：=xlWorksheet
ActiveWorkbook.SaveAs（mypath&“/Extract.xls”）
Application.DisplayAlerts=True
Application.ScreenUpdating=False
计数器=1
范围（“A1”）。选择
Do While Seek（FileNum）这样的东西应该适合你

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

发布您现有的代码？嗯，我看这没有问题；-）抱歉-我用代码更新了我原来的帖子。我没意识到我贴了那个。再次抱歉。您可能应该使用PowerPivot或数据库来完成此操作。Tim-非常感谢您花费的时间和精力。现在试一试。非常感谢你的意见。我希望在不久的将来能有机会回报你的恩惠。向蒂姆道歉-我病了一段时间，今天是我一段时间以来第一次登录。是的，它成功了，再次感谢您的支持。
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