Importing big text/csv file into excel using vba

Question

I get the data in csv file and I need to import the data into excel. I use the below vba code to complete my task (which I also got from some site after modified accordingly):

Sub ImportTextFile()

Dim vFileName

On Error GoTo ErrorHandle

vFileName = Application.GetOpenFilename("CSV Files (*.csv),*.csv")

If vFileName = False Or Right(vFileName, 3) <> "csv" Then
   GoTo BeforeExit
End If

Application.ScreenUpdating = False

Workbooks.OpenText Filename:=vFileName, _
    Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, _
    ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=True, Comma:=False, Space:=False, _
    Other:=False, TrailingMinusNumbers:=True, _
    Local:=True

Columns("A:A").EntireColumn.AutoFit

BeforeExit:
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description
Resume BeforeExit
End Sub

Till now, this code was helping me as the number of rows/records in csv/text file were less than 1,048,576 (which is row limit of excel in a sheet). Now number of records in the csv/text file are 10 times more than the limit.

I need help to

Modify this code, which automatically produces sheets (in the same workbook) and put 1000000 records on each sheet until text/csv file ends.

I appreciate your help on this. thanks

djevulen djevulen · Accepted Answer · 2015-01-03T01:16:59

You can try the below code. You need to change the value of numOfLines variable to 1046000 or whatever you need. Make sure that the Scripting library is switched on in your Excel: Tools > References: Microsoft Scripting Control 1.0 & Microsoft Scriplet Runtime

I tested this code on a .csv file with 80 lines, but I set numOfLines to 10, so I ended up with 8 worksheets each containing just 10 rows from the .csv file. If you change the numOfLines to 1000000, by extension, it should give you appropriate number of worksheets each containing the specified limit of rows.

Hope this helps.

Sub textStreamToExcel()

'Add Scripting references in Tools before you write this code:
'Microsoft Scripting Control 1.0 and Microsoft Scripting Runtime

Dim numOfLines As Long
numOfLines = 10 '################### change this number to suit your needs

'Enter the source file name
Dim vFileName
vFileName = Application.GetOpenFilename("Text Files (*.txt),*.txt")

If vFileName = False Then
    Exit Sub
End If

Dim fso As FileSystemObject
Set fso = New FileSystemObject

Dim ts As TextStream
Dim line As String
Dim counter As Long

Set ts = fso.OpenTextFile(vFileName, ForReading)

Dim wkb As Workbook
Set wkb = Workbooks.Add
wkb.Activate
'Save your file, enter your file name if you wish
Dim vSavedFile
vSavedFile = wkb.Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xls), *.xls")


If vSavedFile = False Then
    Exit Sub
End If

wkb.SaveAs vSavedFile

Dim cwks As Integer
cwks = wkb.Sheets.Count

Dim iwks As Integer
iwks = 1
Dim wkbS As Excel.Worksheet

Application.ScreenUpdating = False
Looping:
counter = 1
If iwks <= cwks Then
    Set wkbS = wkb.Worksheets(iwks)
    wkbS.Activate
    Range("A1").Activate

    While counter <= numOfLines

        If ts.AtEndOfStream <> True Then

            line = ts.ReadLine
            If ActiveCell.Value = "" Then
                ActiveCell.Value = CStr(line)
            End If
            ActiveCell.Offset(1, 0).Activate
            counter = counter + 1
        Else
            ts.Close
            GoTo Ending
        End If
    Wend
Else
    Set wkbS = wkb.Worksheets.Add(After:=Sheets(Sheets.Count))
    wkbS.Activate
    Range("A1").Activate

    While counter <= numOfLines

        If ts.AtEndOfStream <> True Then

            'If the last line has been read it will give you an Input error
            line = ts.ReadLine
            If ActiveCell.Value = "" Then
                ActiveCell.Value = CStr(line)
            End If
            ActiveCell.Offset(1, 0).Activate
            counter = counter + 1
        Else
            ts.Close
            GoTo Ending
        End If
    Wend
End If

iwks = iwks + 1

If ts.AtEndOfStream <> True Then
    GoTo Looping
Else
    GoTo Ending
End If

Ending:
Application.ScreenUpdating = True
Set fso = Nothing
Set ts = Nothing
Set wkb = Nothing
Set wkbS = Nothing
MsgBox "Transfer has been completed"
Exit Sub

ErrorHandler:

MsgBox "The following error has occured:" & Chr(13) & Chr(13) & "Error No: " & Err.Number * Chr(13) & "Description: " & Chr(13) & Err.Description

End Sub

Importing big text/csv file into excel using vba

2 Answers