Import from a delimited textfile
2006-08-28 Import & Export 0 300
This macro imports data from a delimited text file to a worksheet range:
Sub ImportRangeFromDelimitedText(SourceFile As String, SepChar As String, _ TargetWB As String, TargetWS As String, TargetAddress As String) ' Imports the data separated by SepChar in SourceFile to ' Workbooks(TargetWB).Worksheets(TargetWS).Range(TargetAddress) ' Replaces existing data in Workbooks(TargetWB).Worksheets(TargetWS) ' without prompting for confirmation ' Example: ' ImportRangeFromDelimitedText "C:\FolderName\DelimitedText.txt", _ ";", ThisWorkbook.Name, "ImportSheet", "A3" Dim SC As String * 1, TargetCell As Range, TargetValues As Variant Dim r As Long, fLen As Long Dim fn As Integer, LineString As String ' validate the input data if necessary If Dir(SourceFile) = "" Then Exit Sub ' SourceFile doesn't exist If UCase(SepChar) = "TAB" Or UCase(SepChar) = "T" Then SC = Chr(9) Else SC = Left(SepChar, 1) End If ' 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 = ParseDelimitedString(LineString, SC) ' Excel 97 or older 'TargetValues = Split(LineString, SC, -1, vbBinaryCompare) ' Excel 2000 or later UpdateCells TargetCell.Offset(r, 0), TargetValues r = r + 1 Wend Close #fn Application.Calculation = xlCalculationAutomatic NotAbleToImport: ' clean up Set TargetCell = Nothing Application.StatusBar = False End Sub Function ParseDelimitedString(InputString As String, SC As String) As Variant ' returns a variant array containing each single item in ' InputString separated by SC ' use the built-in Split function in Excel 2000 or later Dim i As Integer, tString As String, tChar As String * 1 Dim sCount As Integer, ResultArray() As Variant tString = "" sCount = 0 For i = 1 To Len(InputString) tChar = Mid$(InputString, i, 1) If tChar = SC Then sCount = sCount + 1 ReDim Preserve ResultArray(1 To sCount) ResultArray(sCount) = tString tString = "" Else tString = tString & tChar End If Next i sCount = sCount + 1 ReDim Preserve ResultArray(1 To sCount) ResultArray(sCount) = tString ParseDelimitedString = 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 Long, i As Long If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub r = 1 c = 1 On Error Resume Next c = UBound(TargetValues, 2) - LBound(TargetValues, 2) + 1 r = UBound(TargetValues, 1) - LBound(TargetValues, 1) + 1 Range(TargetRange.Cells(1, 1), _ TargetRange.Cells(1, 1).Offset(r - 1, c - 1)).Formula = TargetValues On Error GoTo 0 End Sub