I have a function within an Excel spreadsheet that pulls data from a fixed width txt file and pastes it into a spreadsheet. The function currently stores each set of data into an array and pastes it in row by row. However, I am getting go a point where the txt file has 90,000 rows in it and the processing time has increased for the macro. I was trying to optimize the macro so that instead of going row by row, it stores all the data into an array and pastes it in all at once to reduce the amount of times the macro calls to the worksheet. Here is the original code:
Function ImportFixedWidth(FileName As String, _
StartCell As Range, _
IgnoreBlankLines As Boolean, _
SkipLinesBeginningWith As String, _
SkipLinesBeginningWith2 As String, _
ByVal FieldSpecs As String) As Long
Dim FINdx As Long
Dim c As Long
Dim r As Range
Dim FNum As Integer
Dim s As String
Dim RecCount As Long
Dim FieldInfos() As String
Dim FInfo() As String
Dim N As Long
Dim T As String
Dim B As Boolean
Dim InfoParts As Variant
Dim rowData As Variant
Application.EnableCancelKey = xlInterrupt
On Error GoTo EndOfFunction:
If Dir(FileName, vbNormal) = vbNullString Then
' file not found
ImportFixedWidth = -1
Exit Function
End If
If Len(FieldSpecs) < 3 Then
' invalid FieldSpecs
ImportFixedWidth = -1
Exit Function
End If
If StartCell Is Nothing Then
ImportFixedWidth = -1
Exit Function
End If
Set r = StartCell(1, 1)
c = r.Column
FNum = FreeFile
FieldInfos = Split(FieldSpecs, "|")
Open FileName For Input Access Read As #FNum
If StrComp(Right(FieldSpecs, 1), "|", vbBinaryCompare) = 0 Then
FieldSpecs = Left(FieldSpecs, Len(FieldSpecs) - 1)
End If
Do
' read the file
Line Input #FNum, s
If (SkipLinesBeginningWith <> vbNullString And StrComp(Left(Trim(s), Len(SkipLinesBeginningWith)), SkipLinesBeginningWith, vbTextCompare) And SkipLinesBeginningWith2 <> vbNullString And StrComp(Left(Trim(s), Len(SkipLinesBeginningWith2)), SkipLinesBeginningWith2, vbTextCompare)) Then
If Len(s) = 0 Then
If IgnoreBlankLines = False Then
Set r = r(2, 1)
Else
' do nothing
End If
Else
If FieldSpecs = vbNullString Then
Else
If ImportThisLine(s) = True Then
FINdx = LBound(FieldInfos)
ReDim rowData(1 To UBound(FieldInfos) + 1)
c = r.Column
Do While FINdx <= UBound(FieldInfos)
InfoParts = Split(FieldInfos(FINdx), ",")
rowData(FINdx - LBound(FieldInfos) + 1) = Mid(s, CLng(InfoParts(0)), CLng(InfoParts(1)))
FINdx = FINdx + 1
Loop
r.Offset(RecCount, 0).Resize(1, UBound(rowData)).Value = rowData
End If
Set r = r(2, 1)
End If
End If
Else
' no skip first char
End If
Loop Until EOF(FNum)
EndOfFunction:
If Err.Number = 0 Then
ImportFixedWidth = RecCount
Else
ImportFixedWidth = -1
End If
Close #FNum
End Function
I tried to update the code to the following to attempt to optimize the performance:
Function ImportFixedWidth(FileName As String, _
StartCell As Range, _
IgnoreBlankLines As Boolean, _
SkipLinesBeginningWith As String, _
SkipLinesBeginningWith2 As String, _
ByVal FieldSpecs As String) As Long
Dim FINdx As Long
Dim c As Long
Dim r As Range
Dim FNum As Integer
Dim s As String
Dim RecCount As Long
Dim FieldInfos() As String
Dim InfoParts As Variant
Dim rowData As Variant
Dim allData() As Variant
Dim numRows As Long
Application.EnableCancelKey = xlInterrupt
On Error GoTo EndOfFunction:
If Dir(FileName, vbNormal) = vbNullString Then
' file not found
ImportFixedWidth = -1
Exit Function
End If
If Len(FieldSpecs) < 3 Then
' invalid FieldSpecs
ImportFixedWidth = -1
Exit Function
End If
If StartCell Is Nothing Then
ImportFixedWidth = -1
Exit Function
End If
Set r = StartCell(1, 1)
c = r.Column
FNum = FreeFile
FieldInfos = Split(FieldSpecs, "|")
Open FileName For Input Access Read As #FNum
If StrComp(Right(FieldSpecs, 1), "|", vbBinaryCompare) = 0 Then
FieldSpecs = Left(FieldSpecs, Len(FieldSpecs) - 1)
End If
Do
' read the file
Line Input #FNum, s
If (SkipLinesBeginningWith <> vbNullString And StrComp(Left(Trim(s), Len(SkipLinesBeginningWith)), SkipLinesBeginningWith, vbTextCompare)) And (SkipLinesBeginningWith2 <> vbNullString And StrComp(Left(Trim(s), Len(SkipLinesBeginningWith2)), SkipLinesBeginningWith2, vbTextCompare)) Then
If Len(s) = 0 Then
If IgnoreBlankLines = False Then
Set r = r(2, 1)
Else
' do nothing
End If
Else
If FieldSpecs = vbNullString Then
Else
If ImportThisLine(s) = True Then
FINdx = LBound(FieldInfos)
ReDim rowData(1 To UBound(FieldInfos) + 1)
c = r.Column
Do While FINdx <= UBound(FieldInfos)
InfoParts = Split(FieldInfos(FINdx), ",")
rowData(FINdx - LBound(FieldInfos) + 1) = Mid(s, CLng(InfoParts(0)), CLng(InfoParts(1)))
FINdx = FINdx + 1
Loop
RecCount = RecCount + 1
ReDim Preserve allData(1 To RecCount)
allData(RecCount) = rowData
End If
Set r = r(2, 1)
End If
End If
Else
' no skip first char
End If
Loop Until EOF(FNum)
If RecCount > 0 Then
numRows = UBound(allData, 1)
StartCell.Resize(numRows, UBound(allData, 2)).Value = allData
End If
EndOfFunction:
If Err.Number = 0 Then
ImportFixedWidth = RecCount
Else
ImportFixedWidth = -1
End If
Close #FNum
End Function
HoweverI am consistently getting a "Subscript out of Range" error on the following line of code:
If RecCount > 0 Then
numRows = UBound(allData, 1)
StartCell.Resize(numRows, UBound(allData, 2)).Value = allData
End If
I put a watch on the code and the array is populating as expected with the data from the txt file. I'm sure there's an easy solution, but is there something that I am missing that would solve the "Subscript out of Range" error? Thank you very much for the help!
This works for me. Data is accumulated and written out in blocks until all the file has been processed.
Sub tester()
Debug.Print ImportFixedWidth("C:\Temp\test.txt", [A1], False, "", "", "12,2|1,3|4,4|12,2|")
End Sub
Function ImportFixedWidth(FileName As String, _
StartCell As Range, _
IgnoreBlankLines As Boolean, _
SkipLinesBeginningWith As String, _
SkipLinesBeginningWith2 As String, _
ByVal FieldSpecs As String) As Long
Const BLOCK_SIZE As Long = 5000 'write this many rows to the sheet once accumulated
Dim FNum As Integer, s As String
Dim FieldInfos As Variant, InfoParts As Variant
Dim allData() As Variant, skip As Boolean, totalLines As Long, numFields As Long
Dim FileContent As String, Lines, i As Long, n As Long, f As Long, el
Application.EnableCancelKey = xlInterrupt
On Error GoTo EndOfFunction:
If Dir(FileName, vbNormal) = vbNullString Then ' file not found?
ImportFixedWidth = -1
Exit Function
End If
If Len(FieldSpecs) < 3 Then ' invalid FieldSpecs?
ImportFixedWidth = -1
Exit Function
End If
If StartCell Is Nothing Then
ImportFixedWidth = -1
Exit Function
End If
If StrComp(Right(FieldSpecs, 1), "|", vbBinaryCompare) = 0 Then
FieldSpecs = Left(FieldSpecs, Len(FieldSpecs) - 1)
End If
FieldInfos = Split(FieldSpecs, "|")
numFields = UBound(FieldInfos) + 1
FNum = FreeFile
Open FileName For Input Access Read As FNum
totalLines = 0
ReDim allData(1 To BLOCK_SIZE, 1 To numFields)
n = 0
Do
Line Input #FNum, s
If Len(s) = 0 Then
If Not IgnoreBlankLines Then n = n + 1 'write blank line?
Else
skip = False
For Each el In Array(SkipLinesBeginningWith, SkipLinesBeginningWith2)
If Len(el) > 0 Then
If InStr(1, s, el, vbTextCompare) = 1 Then
skip = True
Exit For
End If
End If
Next el
If Not skip Then
n = n + 1
For f = LBound(FieldInfos) To UBound(FieldInfos)
InfoParts = Split(FieldInfos(f), ",")
If Len(s) >= CLng(InfoParts(0)) Then
allData(n, f + 1) = Mid(s, CLng(InfoParts(0)), CLng(InfoParts(1)))
End If
Next f
End If 'not skip
End If 'blank line
'at the limit for the block? If yes then write it out and clear it,
' and reset counters etc
If n = BLOCK_SIZE Then
totalLines = totalLines + BLOCK_SIZE
StartCell(1).Resize(BLOCK_SIZE, numFields).Value = allData
Set StartCell = StartCell.Offset(BLOCK_SIZE)
ReDim allData(1 To BLOCK_SIZE, 1 To numFields) 'clear array
n = 0 'reset n
End If
Loop Until EOF(FNum)
If n > 0 Then 'write out any remaining lines
totalLines = totalLines + n
StartCell(1).Resize(n, numFields).Value = allData
End If
Close FNum
EndOfFunction:
If Err.Number = 0 Then
ImportFixedWidth = totalLines
Else
Debug.Print Err.Description
ImportFixedWidth = -1
End If
End Function