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