Fine-tune VBA code

Dear all,

I hope someone is able to help me with this one. I'm using Excel 2007 to import large text files using VBA code. In the text file I'll tell you a bit more about in a moment, the the first column of numbers are longitude, the second latitude and from there on, data point values.

The first problem is that when a very small number is encountered (e.g. 4.2321E-02) in the text file, upon import to Excel, the 'number' is imported into the correct cell, yet the E-02 is put into the adjacent cell, causing the number to be split up - this also causes subsequent values to be shifted one cell further along than they should be. I was wondering therefore if there's a way of keeping the E-02 attached to the end of the number. I've noticed that in the text file sometimes there is a space between the number and the E-x part (most often for the latitude and longitude values) with often no space for the data point values. Any suggestions are of course welcome on how to get round this!

The second problem is a bit of an odd one. Upon import of the data, the final cell of each row and positions in the dataset where there is meant to be no value (ie. a blank cell), a question mark in a box appears (this doesn't appear in the text file). I'm wondering whether this is meant to be some kind of carriage-return marker or something akin to this. Anyway, I thought it would be easy to remove, just using find and replace to make the cell blank once more - however, as this isn't a text character, it won't let me copy and paste it into the find/replace box. So I'm a little confused how to get rid of this.
Each text file is around 300MB (told you it was a large import!), so I've uploaded a smaller sample one to www.megaupload.com in case you need to have a look - it's still quite big mind you. To view it, please go to the following website: http://www.megaupload.com/?d=6NN199FN and enter in the anti-spam code in the top-right corner.

The code as it stands is as follows:

'"Text Files (*.txt),*.txt
Option Explicit
Sub LargeFileImport()
Const MaxRows As Long = 1048576
'Dimension Variables
Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double
Dim num() As Variant
Dim v As Variant, i As Long, j As Long
Dim s As String, sChr As String
Dim rw As Long
'Ask User for File's Name
FileName = Application.GetOpenFilename( _
FileFilter:="Text Files (*.txt),*.txt")
'Check for no entry
If FileName = "" Then End
'Get Next Available File Handle Number
FileNum = FreeFile()
'Open Text File For Input
Open FileName For Input As #FileNum
'Turn Screen Updating Off
'Application.ScreenUpdating = False
'Set The Counter to 1
Counter = 1
'Loop Until the End Of File Is Reached
s = ""
rw = 1
Do While Seek(FileNum) <= LOF(FileNum)
'Display Importing Row Number On Status Bar
' Application.StatusBar =
Debug.Print "Importing Row " & _
Counter & " of text file " & FileName
'Store One Line Of Text From File To Variable
ResultStr = Input(1000, #FileNum)
'Store Variable Data Into Active Cell
For i = 1 To Len(ResultStr)
sChr = Mid(ResultStr, i, 1)
If Asc(sChr) = 10 Then
If Len(Trim(s)) > 0 Then
v = Split(Application.Trim(s), " ")
ReDim num(LBound(v) To UBound(v))
For j = LBound(v) To UBound(v)
num(j) = v(j)
Next
' Change 'rw' no. to alter import starting column
Cells(rw, 1).Resize(1, _
UBound(v) - LBound(v) + 1) = num
rw = rw + 1
s = ""
Erase v
If rw > MaxRows Then
ActiveSheet.Next.Select
rw = 1
End If
End If
Else
s = s & sChr
End If
Next
'Increment the Counter By 1
Counter = Counter + 1
' If Counter > 1E+307 Then
' Exit Do
' End If
'Start Again At Top Of 'Do While' Statement
Loop
'Close The Open Text File
Close
If Len(Trim(s)) > 0 Then
v = Split(Application.Trim(s), " ")
ReDim num(LBound(v) To UBound(v))
For j = LBound(v) To UBound(v)
num(j) = CSng(v(j))
Next
' Change 'rw' no. to alter import starting column
Cells(rw, 1).Resize(1, _
UBound(v) - LBound(v) + 1) = num
rw = rw + 1
s = ""
Erase v
If rw > 1048576 Then
ActiveSheet.Next.Select
rw = 1
End If
End If

'Remove Message From Status Bar
Application.StatusBar = False
End Sub

Many thanks for your time and effort, I appreciate it.

Best wishes,
smurray444

Comments

  • [color=Blue][/color]

    Hi,

    I think, the text file is an output of some application.
    Try to modify the output so that some special character is inserted in between the numbers. Then it will be easier in splitting the numbers without losing "E-xx".

    : Dear all,
    :
    : I hope someone is able to help me with this one. I'm using Excel
    : 2007 to import large text files using VBA code. In the text file
    : I'll tell you a bit more about in a moment, the the first column of
    : numbers are longitude, the second latitude and from there on, data
    : point values.
    :
    : The first problem is that when a very small number is encountered
    : (e.g. 4.2321E-02) in the text file, upon import to Excel, the
    : 'number' is imported into the correct cell, yet the E-02 is put into
    : the adjacent cell, causing the number to be split up - this also
    : causes subsequent values to be shifted one cell further along than
    : they should be. I was wondering therefore if there's a way of
    : keeping the E-02 attached to the end of the number. I've noticed
    : that in the text file sometimes there is a space between the number
    : and the E-x part (most often for the latitude and longitude values)
    : with often no space for the data point values. Any suggestions are
    : of course welcome on how to get round this!
    :
    : The second problem is a bit of an odd one. Upon import of the data,
    : the final cell of each row and positions in the dataset where there
    : is meant to be no value (ie. a blank cell), a question mark in a box
    : appears (this doesn't appear in the text file). I'm wondering
    : whether this is meant to be some kind of carriage-return marker or
    : something akin to this. Anyway, I thought it would be easy to
    : remove, just using find and replace to make the cell blank once more
    : - however, as this isn't a text character, it won't let me copy and
    : paste it into the find/replace box. So I'm a little confused how to
    : get rid of this.
    : Each text file is around 300MB (told you it was a large import!),
    : so I've uploaded a smaller sample one to www.megaupload.com in case
    : you need to have a look - it's still quite big mind you. To view it,
    : please go to the following website:
    : http://www.megaupload.com/?d=6NN199FN and enter in the anti-spam
    : code in the top-right corner.
    :
    : The code as it stands is as follows:
    :
    : '"Text Files (*.txt),*.txt
    : Option Explicit
    : Sub LargeFileImport()
    : Const MaxRows As Long = 1048576
    : 'Dimension Variables
    : Dim ResultStr As String
    : Dim FileName As String
    : Dim FileNum As Integer
    : Dim Counter As Double
    : Dim num() As Variant
    : Dim v As Variant, i As Long, j As Long
    : Dim s As String, sChr As String
    : Dim rw As Long
    : 'Ask User for File's Name
    : FileName = Application.GetOpenFilename( _
    : FileFilter:="Text Files (*.txt),*.txt")
    : 'Check for no entry
    : If FileName = "" Then End
    : 'Get Next Available File Handle Number
    : FileNum = FreeFile()
    : 'Open Text File For Input
    : Open FileName For Input As #FileNum
    : 'Turn Screen Updating Off
    : 'Application.ScreenUpdating = False
    : 'Set The Counter to 1
    : Counter = 1
    : 'Loop Until the End Of File Is Reached
    : s = ""
    : rw = 1
    : Do While Seek(FileNum) <= LOF(FileNum)
    : 'Display Importing Row Number On Status Bar
    : ' Application.StatusBar =
    : Debug.Print "Importing Row " & _
    : Counter & " of text file " & FileName
    : 'Store One Line Of Text From File To Variable
    : ResultStr = Input(1000, #FileNum)
    : 'Store Variable Data Into Active Cell
    : For i = 1 To Len(ResultStr)
    : sChr = Mid(ResultStr, i, 1)
    : If Asc(sChr) = 10 Then
    : If Len(Trim(s)) > 0 Then
    : v = Split(Application.Trim(s), " ")
    : ReDim num(LBound(v) To UBound(v))
    : For j = LBound(v) To UBound(v)
    : num(j) = v(j)
    : Next
    : ' Change 'rw' no. to alter import starting column
    : Cells(rw, 1).Resize(1, _
    : UBound(v) - LBound(v) + 1) = num
    : rw = rw + 1
    : s = ""
    : Erase v
    : If rw > MaxRows Then
    : ActiveSheet.Next.Select
    : rw = 1
    : End If
    : End If
    : Else
    : s = s & sChr
    : End If
    : Next
    : 'Increment the Counter By 1
    : Counter = Counter + 1
    : ' If Counter > 1E+307 Then
    : ' Exit Do
    : ' End If
    : 'Start Again At Top Of 'Do While' Statement
    : Loop
    : 'Close The Open Text File
    : Close
    : If Len(Trim(s)) > 0 Then
    : v = Split(Application.Trim(s), " ")
    : ReDim num(LBound(v) To UBound(v))
    : For j = LBound(v) To UBound(v)
    : num(j) = CSng(v(j))
    : Next
    : ' Change 'rw' no. to alter import starting column
    : Cells(rw, 1).Resize(1, _
    : UBound(v) - LBound(v) + 1) = num
    : rw = rw + 1
    : s = ""
    : Erase v
    : If rw > 1048576 Then
    : ActiveSheet.Next.Select
    : rw = 1
    : End If
    : End If
    :
    : 'Remove Message From Status Bar
    : Application.StatusBar = False
    : End Sub
    :
    : Many thanks for your time and effort, I appreciate it.
    :
    : Best wishes,
    : smurray444
    :
    :

Sign In or Register to comment.

Howdy, Stranger!

It looks like you're new here. If you want to get involved, click one of these buttons!

Categories

In this Discussion