Question

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

任何人都可以帮我创建以下的VBA代码：

打开文本文件，一次复制数据200,000行。
将数据放入Excel（未格式化）。
从文本文件（etc）中获取下一个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

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

1 个答案: