Importing part of textfile

[Dolf.Limmen]

Hi,

I would like to import only a part of a text file. In excel 2003SP3

I already tried to import the file first and find the data later, but that does not work. I found somewhere on the web that excel can handle only files smaller as 64k. And this file is larger.

So I am looking for some code which opens a file and copies the lines from a line which concains a "string" to EOF.

Hope someone can help me!

Grz

Dolf

[GTO]

...I would like to import only a part of a text file. In excel 2003SP3

I already tried to import the file first and find the data later, but that does not work. I found somewhere on the web that excel can handle only files smaller as 64k. And this file is larger.

So I am looking for some code which opens a file and copies the lines from a line which concains a "string" to EOF...

Greetings Dolf,

Welcome to vbaexpress and a friendly Howdy from Arizona:hi:

In regards to your issue, you can import more than the 65536 row limit, it just has to be done programmatically AFAIK.

In this example, we just grab the lines from where we found the text, as per your request, through the end of the file. You'll see that if there are more than 65000 lines (just where I chose to break sheets), a new sheet is added and we keep going.

Option Explicit

Sub TextFile_ReadFromFoundString()
'// FSO = FileSystemObject, fsoTextStream = TextStream //
Dim _
FSO As Object, _
fsoTextStream As Object, _
wbNew As Workbook, _
wksCurr As Worksheet, _
strFilNam As String, _
aryVals As Variant, _
aryTransposed As Variant, _
i As Long, _
lSkipLines As Long, _
lMaxLines As Long, _
lLinesToProcess As Long, _
bolFound As Boolean

'// Change string to suit. //
Const TEXT_2_FIND As String = "Here's my text"

'Dim Start As Single: Start = Timer

strFilNam = Application.GetOpenFilename(FileFilter:="Text Files (*.txt),*.txt", _
Title:="Choose file to parse/import.", _
MultiSelect:=False)
'// If user cancels, .GetOpenFilename will return "False". //
If strFilNam = "False" Then Exit Sub

Set FSO = CreateObject("Scripting.FileSystemObject")
Set fsoTextStream = FSO.OpenTextFile(FileName:=strFilNam, _
IOMode:=1, _
Format:=-2) '1=ForReading, -2=TristateUseDefault
With fsoTextStream
'// Count lines in txtfile, while trying to find string. //
i = 0
Do While Not .AtEndOfStream
i = i + 1
If InStr(1, .ReadLine, TEXT_2_FIND, vbTextCompare) > 0 Then
lSkipLines = i - 1
bolFound = True
End If
Loop
.Close
End With
'// If we didn't find our text, bail. //
If Not bolFound Then Exit Sub

lLinesToProcess = i = lSkipLines
Application.ScreenUpdating = False

'// Set a reference to a new wb, and its only sheet. //
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wksCurr = wbNew.Worksheets(1)
Set fsoTextStream = FSO.OpenTextFile(FileName:=strFilNam, _
IOMode:=1, _
Format:=-2)
With fsoTextStream
i = 0
'// Skip number of lines previously determined. //
Do While Not .AtEndOfStream And Not i >= lSkipLines
.SkipLine
i = i + 1
Loop

'// Change to suit; I elected to keep an even amount of lines per excel sheet. //
'// Self-adjusting for 2007... //
If Rows.Count > 1000000 Then
lMaxLines = 1000000
Else
lMaxLines = 65000
End If

'// Initially size our first array //
ReDim aryVals(0 To 0)
i = 0
'// Loop until end of textstream is reached. //
Do While Not .AtEndOfStream
'// Use UBound of first array to determine when to dump array onto sheet. //
If Not UBound(aryVals) >= lMaxLines Then
'// Resize array, maintaining previous vals. //
ReDim Preserve aryVals(1 To UBound(aryVals) + 1)
aryVals(UBound(aryVals)) = .ReadLine
Else
'// When time to dump array onto sheet, we'll create another array, this//
'// one a two-dimensional array (x rows by 1 col). //
'// Basically, we are "manually" transposing first array; as while //
'// Application.Transpose could be used, I've had it balk on a computer //
'// with less than stellar memory when handling large arrays. //
ReDim aryTransposed(LBound(aryVals) To UBound(aryVals), 1 To 1)
'// Fill second array from first. //
For i = LBound(aryVals) To UBound(aryVals)
aryTransposed(i, 1) = aryVals(i)
Next
'// Dump second array onto sheet in one swoop. //
wksCurr.Range(wksCurr.Cells(2, 1), _
wksCurr.Cells(UBound(aryTransposed, 1) + 1, 1)).Value _
= aryTransposed
'// Empty and take our array back to 0 to 0 //
ReDim aryVals(0 To 0)
'// Add and set a reference to another new sheet for next go around. //
wbNew.Worksheets.Add After:=wbNew.Worksheets(wbNew.Worksheets.Count)
Set wksCurr = wbNew.Worksheets(wbNew.Worksheets.Count)
End If
Loop

'// Most likely there will be vals left for a partial sheet; handle here. //
If UBound(aryVals) > 0 Then
ReDim aryTransposed(LBound(aryVals) To UBound(aryVals), 1 To 1)
For i = LBound(aryVals) To UBound(aryVals)
aryTransposed(i, 1) = aryVals(i)
Next
wksCurr.Range(wksCurr.Cells(2, 1), _
wksCurr.Cells(UBound(aryTransposed, 1) + 1, 1)).Value _
= aryTransposed
Else
'// On the extremely odd chance that we ended at the end of a sheet, delete //
'// blank sheet. //
Application.DisplayAlerts = False
wksCurr.Delete
Application.DisplayAlerts = True
End If
'// Close txtfile //
.Close
End With

Application.ScreenUpdating = True
'Debug.Print "Array: " & Timer - Start
End Sub


Does that help?

Mark

[Dolf.Limmen]

Wow!

I was hoping for hints how to do this and you gave me just the whole solution! Thanks a lot! I tried it this morning and it works good!

I will be able to finish my document thanks to this!
:beerchug:

Grz

Dolf

[GTO]

Wow!

I was hoping for hints how to do this and you gave me just the whole solution! Thanks a lot! I tried it this morning and it works good!

I will be able to finish my document thanks to this!
:beerchug:

Grz

Dolf

Well.... :biggrin: I ain't usually nearly that slick, but had the unusual happen in that I had just answered something very similar. Glad that worked for you!

Mark