VBScript - Import a Large Text File

VBScript - Import a Large Text File (Imports a text file into Excel even if the number of lines in that file exceeds Excel's total number of rows limitation. )


' This script was written for folks trying to import a text file into
' Excel 2003 that exceed the row limitations.
' This version works on Windows XP and has not been tested on any other OS.

Const ForReading = 1 
Const ForAppending = 2 

Set objDialog = CreateObject("UserAccounts.CommonDialog") 

objDialog.Filter = "All Files|*.*" 
objDialog.InitialDir = "C:\" 
intResult = objDialog.ShowOpen 

If intResult = 0 Then 
Wscript.Quit 
Else 
BreakFile =  objDialog.FileName 
End If 

Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set objFile = objFSO.OpenTextFile(BreakFile, ForReading) 

FiletoSplit = objFSO.GetFileName(BreakFile) 
FolderDest = Mid(objFSO.GetAbsolutePathName(BreakFile),1, _
Len(objFSO.GetAbsolutePathName(BreakFile))-(Len(FiletoSplit))) 
FileSplitName = objFSO.GetBaseName(BreakFile) 



dtmStart = Now() 
strContents = objFile.ReadAll 
FileNum = 1 
fname =  FolderDest & FileSplitName & "Split_" & FileNum & ".txt" 
Set objFile1 = objFSO.OpenTextFile(fname, ForAppending, True) 



CountLines = 0 
arrLines = Split(strContents, vbCrLf) 

If ubound(arrLines) < 64500 Then 
        msgbox "This file will fit into Excel already.  No split is necessary.",48,"SplitFile" 
        Wscript.Quit 
End If 

        HeaderText = arrLines(0) 
                For i = 0 to ubound(arrlines)                   
                        strLine = arrLines(i) & vbCrLf                  
                        objFile1.Write strLine                  
                        If  (Countlines) < 64500  Then                          
                                countlines = countlines + 1                     
                        ElseIf Countlines >= 64500 Then 
objFile1.Close 
Countlines = 0                          
FileNum = FileNum + 1 
fname = FolderDest & FileSplitName & "Split_" & FileNum & ".txt" 
Set objFile1 = objFSO.OpenTextFile(fname, ForAppending, True) 
objFile1.Write HeaderText & vbCrLf                              
End If          
Next 

objFile.Close 
dtmEnd = Now() 
If MsgBox("There were " & FileNum & " files created." & vbcrlf & _ 
"The files were put into this folder:  " & FolderDest & _ 
vbCrLf & "The script took " & DateDiff("s", dtmStart, dtmEnd) & " seconds " & _ 
"to break the " &  FiletoSplit & " file." & vbcrlf & vbcrLF & _ 
"Click OK to open destination folder or CANCEL to quit.",  _ 
1,"SplitFile") = vbOK Then 
Set objShell = CreateObject("Shell.Application") 
strPath = FolderDest 

objShell.Explore strPath 
End If

[Via]