Import from a fixed-width textfile

This macro imports data from a fixed-width textfile to a worksheet range:
Sub ImportRangeFromFixedText(SourceFile As String, ColumnWidths As Variant, _
    TargetWB As String, TargetWS As String, TargetAddress As String)
' Imports the fixed-width formatted data in SourceFile to 
' Workbooks(TargetWB).Worksheets(TargetWS).Range(TargetAddress)
' Replaces existing data in Workbooks(TargetWB).Worksheets(TargetWS) 
' without prompting for confirmation
' ColumnWidths must contain an array of integers corresponding to 
' the data column widths (e.g. Array(5, 10, 15, 20))
' Example:     
' ImportRangeFromFixedText "C:\FolderName\FixedWidthText.txt", _
'     Array(5, 10, 15, 20, 25), ThisWorkbook.Name, "ImportSheet", "A3"


Dim TargetCell As Range, TargetValues As Variant
Dim r As Long, fLen As Long
Dim fn As Integer, LineString As String
Dim ColWidth As Integer
    ' validate the input data if necessary
    If Dir(SourceFile) = "" Then Exit Sub ' SourceFile doesn't exist
    
    ' perform import
    Workbooks(TargetWB).Activate
    Worksheets(TargetWS).Activate
    Set TargetCell = Range(TargetAddress).Cells(1, 1)
    On Error GoTo NotAbleToImport
    fn = FreeFile
    Open SourceFile For Input As #fn
    On Error GoTo 0
    fLen = LOF(fn)
    r = 0
    While Not EOF(fn)
        Line Input #fn, LineString
        If r Mod 100 = 0 Then
            Application.StatusBar = "Reading data from " & _
                SourceFile & " " & _
                Format(Seek(fn) / fLen, "0 %") & "..."
        End If
        TargetValues = ParseFixedString(LineString, ColumnWidths)
        UpdateCells TargetCell.Offset(r, 0), TargetValues
        r = r + 1
    Wend
    Close #fn
    Application.Calculation = xlCalculationAutomatic
NotAbleToImport:
    Set TargetCell = Nothing
    Application.StatusBar = False
End Sub

Function ParseFixedString(InputString As String, _
    ColumnWidths As Variant) As Variant
' returns a variant array containing each single item in 
' InputString separated by ColumnsWidths characters
Dim ResultArray() As Variant, lb As Integer, ub As Integer, tString As String
Dim cCount As Integer, c As Integer, StartPos As Integer, cWidth As Integer
    cCount = 1
    On Error Resume Next
    ub = UBound(ColumnWidths)
    lb = LBound(ColumnWidths)
    cCount = ub - lb + 1
    On Error GoTo 0
    If cCount = 1 Then
        ParseFixedString = InputString
        Exit Function
    End If
    ReDim ResultArray(1 To cCount)
    StartPos = 1
    For c = lb To ub
        cWidth = ColumnWidths(c)
        tString = Mid$(InputString, StartPos, cWidth)
        tString = Trim(tString) ' remove extra spaces
        If lb = 0 Then
            ResultArray(c + 1) = tString
        Else
            ResultArray(c) = tString
        End If
        StartPos = StartPos + cWidth
    Next c
    ParseFixedString = ResultArray
End Function

Sub UpdateCells(TargetRange As Range, TargetValues As Variant)
' Writes the content of the variable TargetValues to 
' the active worksheet range starting at TargetRange
' Replaces existing data in TargetRange without prompting for confirmation
Dim r As Long, c As Integer
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    r = 1
    c = 1
    On Error Resume Next
    c = UBound(TargetValues, 1)
    r = UBound(TargetValues, 2)
    Range(TargetRange.Cells(1, 1), _
        TargetRange.Cells(1, 1).Offset(r - 1, c - 1)).Formula = TargetValues
    On Error GoTo 0
End Sub
Document last updated 1999-10-13 12:50:53 Printerfriendly version