How Do I Modify Pearson's Code to Add "Treat Consecutive Delimiters As One"?

[Alicia7Jaynes]

Hello.

I found some really neat code by Chip Pearson
(http://www.cpearson.com/excel/imptext.htm) that enables the user to
specify a filename and delimiter, and then imports that file into an
existing Excel worksheet using the said delimiter.

My problem is that the text files I need to import use VARYING amounts
of spaces as delimiters; therefore, my columns will not align
correctly. I think I can work around this if I could modify Pearson's
code so that it "treats consecutive delimiters as one" (an option that
can be selected in the Import Wizard).

I have very little experience in VBA, so I don't know how to modify it.
Can someone help me?

Thanks,
Alicia


Here is the code "as is":

Public Sub ImportTextFile(FName As String, Sep As String)

Dim RowNdx As Integer
Dim ColNdx As Integer
Dim TempVal As Variant
Dim WholeLine As String
Dim Pos As Integer
Dim NextPos As Integer
Dim SaveColNdx As Integer

Application.ScreenUpdating = False
'On Error GoTo EndMacro:

SaveColNdx = ActiveCell.Column
RowNdx = ActiveCell.row

Open FName For Input Access Read As #1

While Not EOF(1)
Line Input #1, WholeLine
If Right(WholeLine, 1) <> Sep Then
WholeLine = WholeLine & Sep
End If
ColNdx = SaveColNdx
Pos = 1
NextPos = InStr(Pos, WholeLine, Sep)
While NextPos >= 1
TempVal = Mid(WholeLine, Pos, NextPos - Pos)
Cells(RowNdx, ColNdx).Value = TempVal
Pos = NextPos + 1
ColNdx = ColNdx + 1
NextPos = InStr(Pos, WholeLine, Sep)
Wend
RowNdx = RowNdx + 1
Wend

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #1

End Sub

________________________________________

Since this code has parameters, it will not appear in the standard
"Macros" dialog list (ALT+F8). The following procedure will prompt you
for the filename and delimiter character, and then run the
ImportTextFile procedure.

Public Sub DoTheImport()
Dim FName As Variant
Dim Sep As String

FName = Application.GetOpenFilename _
(filefilter:="Text Files(*.txt),*.txt,All Files (*.*),*.*")
If FName = False Then
MsgBox "You didn't select a file"
Exit Sub
End If

Sep = InputBox("Enter a single delimiter character.", _
"Import Text File")
ImportTextFile CStr(FName), Sep

End Sub

 

[Bob Phillips]

Bit kludgy, but try this

Public Sub ImportFile()
Dim FName As Variant
Dim Sep As String
Dim RowNdx As Integer
Dim ColNdx As Integer
Dim TempVal As Variant
Dim WholeLine As String
Dim Pos As Integer
Dim NextPos As Integer
Dim SaveColNdx As Integer
Dim arySeps
Dim i As Long, j As Long, iPrev As Long

FName = Application.GetOpenFilename _
(filefilter:="Text Files(*.txt),*.txt,All Files (*.*),*.*")
If FName = False Then
MsgBox "You didn't select a file"
Exit Sub
End If

arySeps = Array("|", ":", ";")

Application.ScreenUpdating = False
'On Error GoTo EndMacro:

Open FName For Input Access Read As #1

SaveColNdx = ActiveCell.Column
RowNdx = ActiveCell.Row

While Not EOF(1)
Line Input #1, WholeLine
If Right(WholeLine, 1) <> Sep Then
WholeLine = WholeLine & Sep
End If
ColNdx = SaveColNdx
iPrev = 1
For i = 1 To Len(WholeLine)
For j = LBound(arySeps) To UBound(arySeps)
If Mid(WholeLine, i, 1) = arySeps(j) Then
Cells(RowNdx, ColNdx).Value = Mid(WholeLine, iPrev, i -
iPrev)
iPrev = i + 1
ColNdx = ColNdx + 1
Exit For
End If
Next j
Next i
Cells(RowNdx, ColNdx).Value = Mid(WholeLine, iPrev, i - iPrev)
RowNdx = RowNdx + 1
Wend

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #1

End Sub

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

 

[Chip Pearson]

Alicia,

Insert the line

WholeLine = Application.WorksheetFunction.Trim(WholeLine)

immediately AFTER

Line Input #1, WholeLine


--
Cordially,
Chip Pearson
Microsoft MVP - Excel
Pearson Software Consulting, LLC
www.cpearson.com

 

[Executor]

Hi Alicia,

I have used you code as a base and added a few lines

Public Sub ImportTextFile(FName As String, Sep As String)

Dim RowNdx As Integer
Dim ColNdx As Integer
Dim TempVal As Variant
Dim WholeLine As String
Dim NextPos As Integer
Dim SaveColNdx As Integer


Application.ScreenUpdating = False
'On Error GoTo EndMacro:

SaveColNdx = ActiveCell.Column
RowNdx = ActiveCell.Row


Open FName For Input Access Read As #1


While Not EOF(1)
Line Input #1, WholeLine
If Right(WholeLine, 1) <> Sep Then
WholeLine = WholeLine & Sep
End If
ColNdx = SaveColNdx
NextPos = InStr(1, WholeLine, Sep)
While NextPos >= 1
TempVal = Left(WholeLine, NextPos - 1)
Cells(RowNdx, ColNdx).Value = TempVal
ColNdx = ColNdx + 1
WholeLine = LTrim(WholeLine)
NextPos = InStr(1, WholeLine, Sep)
Wend
RowNdx = RowNdx + 1
Wend


EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #1


End Sub


HTH,

Executor

 

[Alicia7Jaynes]

Thanks so much, guys... I was in a real crunch with this!

I ended up adding Mr. Pearson's extra line because it worked best for
my particular situation.

Thanks again.

Alicia