Importerer data fra en tegn-separert tekstfil

Denne makroen importerer data til et regnearkområde fra en tegn-separert tekstfil med valgfritt skilletegn (CSV/SDV-format):

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 eller eldre
        'TargetValues = Split(LineString, SC, -1, vbBinaryCompare) ' Excel 2000 eller nyere
        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
' returnerer en matrisevariabel med alle elementene i InputString adskilt med SC
' bruk den innebygde Split-funksjonen i Excel 2000 eller nyere
Dim i As Integer, tString As String, tChar As String * 1, sCount As Integer
Dim 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

Dokumentet er sist oppdatert 2006-08-28 16:00:21 Utskriftsvennlig versjon