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

时间:2012-08-25 18:50:40

标签: excel-vba vba excel

我有一个包含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。

1 个答案:

答案 0 :(得分: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