Eksporter data til en tegnseparert tekstfil

Denne makroen eksporterer verdier eller formler fra et regnearkområde til en tegn-separert tekstfil med valgfritt skilletegn (CSV/SDV-format):

Sub ExportRangeAsDelimitedText(SourceWB As String, SourceWS As String, _
    SourceAddress As String, TargetFile As String, SepChar As String, _
    SaveValues As Boolean, ExportLocalFormulas As Boolean, AppendToFile As Boolean)
' Exports the data in Workbooks(SourceWB).Worksheets(SourceWS).Range(SourceAddress) to
' the textfile TargetFile in CSV format, uses SepChar as column delimiter
' Example:     ExportRangeAsDelimitedText ThisWorkbook.Name, _
        "ExportSheet", "A3:E23", _
        "C:\FolderName\DelimitedText.txt", ";", True, True, False


Dim SourceRange As Range, SC As String * 1
Dim A As Integer, r As Long, c As Integer, totr As Long, pror As Long
Dim fn As Integer, LineString As String, tLine As String
    ' validate the input data if necessary
    Workbooks(SourceWB).Activate
    Worksheets(SourceWS).Activate
    If Application.WorksheetFunction.CountA(Range(SourceAddress)) = 0 Then Exit Sub
    If Not AppendToFile Then
        If Dir(TargetFile) <> "" Then
            On Error Resume Next
            Kill TargetFile
            On Error GoTo 0
            If Dir(TargetFile) <> "" Then
                MsgBox TargetFile & _
                    " already exists, rename, move or delete the file before you try again.", _
                    vbInformation, "Export range to textfile"
                Exit Sub
            End If
        End If
    End If
    If UCase(SepChar) = "TAB" Or UCase(SepChar) = "T" Then
        SC = Chr(9)
    Else
        SC = Left(SepChar, 1)
    End If
    
    ' perform export
    Set SourceRange = Range(SourceAddress)
    On Error GoTo NotAbleToExport
    fn = FreeFile
    Open TargetFile For Append As #fn ' open textfile for new input
    On Error GoTo 0
    ' determine the total number of rows to process
    totr = 0
    For A = 1 To SourceRange.Areas.Count
        totr = totr + SourceRange.Areas(A).Rows.Count
    Next A
    ' start writing the character-separated textfile
    pror = 0
    For A = 1 To SourceRange.Areas.Count
        For r = 1 To SourceRange.Areas(A).Rows.Count
            LineString = ""
            For c = 1 To SourceRange.Areas(A).Columns.Count
                tLine = ""
                On Error Resume Next
                If SaveValues Then
                    tLine = SourceRange.Areas(A).Cells(r, c).Value
                Else
                    If ExportLocalFormulas Then
                        tLine = SourceRange.Areas(A).Cells(r, c).FormulaLocal
                    Else
                        tLine = SourceRange.Areas(A).Cells(r, c).Formula
                    End If
                End If
                On Error GoTo 0
                LineString = LineString & tLine & SC
            Next c
            pror = pror + 1
            If pror Mod 50 = 0 Then
                Application.StatusBar = _
                    "Writing delimited textfile " & _
                    Format(pror / totr, "0 %") & "..."
            End If
            If Len(LineString) > 1 Then 
                LineString = Left(LineString, Len(LineString) - 1)
            End If
            If LineString = "" Then
                Print #fn,
            Else
                Print #fn, LineString
            End If
        Next r
    Next A
    Close #fn ' close the textfile
NotAbleToExport:
    Set SourceRange = Nothing
    Application.StatusBar = False
End Sub

Dokumentet er sist oppdatert 1999-10-13 12:36:45 Utskriftsvennlig versjon