Import from a fixed-width textfile
1999-10-13 Import & Export 0 365
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