Read HUGE text file and copy to excel

[valendj]

Hello,
I have a very large text file in which I need to look for a part number in the text file and then copy the next 14 values below the part number. I would ideally like to run a macro on a list of part numbers around 400-part numbers in column “A” then find the part number in the text file and copy the next 14 values and paste into columns so Row 1 would have the part number and the 14 values after the part (A1 = Part, A2 = value 1,Value 2….) I hope this makes sense and is even possible I found other text readers but the file is too large and I tried changing the text to a CSV and then using a find duplicates and a transpose but again the file is too large I am only a third of the way through the file and excel hit A65536 which I believe is my maximum (excel 2000). I spent a lot of time trying to figure this out and I am having no luck. I hoping I can pull out the 400 part numbers and 14 values out of the text file rather then using the find function and manual typing them in. Thanks for any help!

The text file reads as such
Part Number (8338883)
Value1
Value2
Value3
Value4
Value5
Value6
Value7
Value8
Value9
Value10
Value11
Value12
Value13
Value14
Part Number (9T6068)
Value1

[p45cal]

What we could really do with is a snipped version of the text file; a file with all the data at its start intact, and including say 10 or so part numbers to be found (and if the last bit is different from the main part, then that too).

[mohanvijay]

could you post a full or small part of text file

[valendj]

Because a text file is not an Vbaexpress acceptable format. I converted to a CSV. So if you need a text then just change the file extension in the save as from .csv to .txt

[mostafa90]

it worth a try

[Paul_Hossler]

Suggestion



Option Explicit

Sub BigFile()
Dim iRow As Long, iFile As Long, iCol As Long
Dim sLine As String
Const sFilePath = "D:\demand.txt"
' Obtain next free file handle number
iFile = FreeFile()
Application.ScreenUpdating = False
' Attempt to open file for read
Open sFilePath For Input As #iFile
iRow = 1
Do While Not EOF(iFile)
Application.StatusBar = "Line " & iRow
For iCol = 1 To 15
Line Input #iFile, sLine
ActiveSheet.Cells(iRow, iCol).Value = sLine
Next
iRow = iRow + 1
Loop
Close #iFile
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub


Paul

[p45cal]

an adaptation of Paul's code to cater for "a list of part numbers around 400-part numbers in column “A”" although this code, rather than place values like "A1 = Part, A2 = value 1,Value 2…." places them: A1 = Part, B1 = value 1,C1 =Value 2….


Sub BigFile()
Dim iRow As Long, iFile As Long, iCol As Long
Dim sLine As String, lastrow As Long, cll As Range
Const sFilePath = "C:\demand.txt"
Application.ScreenUpdating = False
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For Each cll In Range("A2:A" & lastrow).Cells
iFile = FreeFile()
' Attempt to open file for read
Open sFilePath For Input As #iFile
iRow = 1
Do While Not EOF(iFile)
Line Input #iFile, sLine
If sLine = cll.Value Then
For iCol = 2 To 15
Line Input #iFile, sLine
ActiveSheet.Cells(cll.Row, iCol).Value = sLine
Next
Exit Do
End If
iRow = iRow + 1
Loop
Close #iFile
Next cll
Application.ScreenUpdating = True
End Sub
It's not especially efficient since it opens and closes the text file many times.

[mohanvijay]

try this


Sub T_Import()
Dim Fi_Dlg As FileDialog
Dim Txt_File As String
Set Fi_Dlg = Application.FileDialog(msoFileDialogFilePicker)
Fi_Dlg.Filters.Add "Text Files", "*.txt"
If Fi_Dlg.Show = -1 Then
Txt_File = Fi_Dlg.SelectedItems(1)
Else
Set Fi_Dlg = Nothing
MsgBox "Please Select text file to import"
Exit Sub
End If
Set Fi_Dlg = Nothing
Dim FSO As Object
Dim Fi_Ob As Object
Dim WS_This As Worksheet
Dim Last_Rw As Long
Dim T_Str As String, Rng_Fi As String
Dim Rng As Range
Dim ii As Integer
Dim T_Lng As Long
Set WS_This = ThisWorkbook.Sheets("Sheet1")
Last_Rw = WS_This.Cells(Rows.Count, 1).End(xlUp).Row
Rng_Fi = "A2:A" & Last_Rw
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fi_Ob = FSO.opentextfile(Txt_File)
With Fi_Ob
Do Until .AtEndOfStream = True
T_Str = .ReadLine
Set Rng = WS_This.Range(Rng_Fi).Find(T_Str, , , xlWhole)
If Not Rng Is Nothing Then
T_Lng = Rng.Row
For ii = 1 To 14
WS_This.Cells(T_Lng, 1 + ii).Value = .ReadLine
Next ii
Else
For ii = 1 To 14
.ReadLine
Next ii
End If
Set Rng = Nothing
Loop
.Close
End With
Set Fi_Ob = Nothing
Set FSO = Nothing
Set WS_This = Nothing
End Sub

[mdmackillop]

Untested.

Option Explicit

Sub GetTxt()
Dim Txt_File As String
Dim Prt As String
Dim t As Variant
Dim i As Long
Dim FSO, MyTxt
Txt_File = "C:\AAA\Demand.txt"
Prt = "4B1031"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set MyTxt = FSO.opentextfile(Txt_File)
t = Split(MyTxt.Readall, Prt)
t = Split(t(1), Chr(10))
Cells(1, 1) = Prt
For i = 1 To 14
Cells(i + 1, 1) = t(i)
Next
MyTxt.Close
End Sub

[valendj]

Thank you this code worked great!