Gibt es eine Möglichkeit zu schreiben, reicht in der Masse zu einer text - /CSV-Datei?

Ich Ihnen geschrieben habe, dies könnte noch verbessert werden, aber ich denke, es ist gut genug:

Sub SaveRangeAsCSV(r As Range, filename As String, overwrite As Boolean)
    Dim wB As Workbook
    Dim c As Range
    Dim usedRows As Long
    If overwrite Then
        If Dir(filename) <> "" Then Kill filename
        If Err.Number <> 0 Then
            MsgBox "Could not delete previously existing file." & vbNewLine & Err.Number & ": " & Err.Description
            Exit Sub
        End If
    End If
    If Dir(filename) <> "" Then
        Set wB = Workbooks.Open(filename)
    Else
        Set wB = Workbooks.Add
    End If

    With wB.Sheets(1)
        usedRows = .UsedRange.Rows.Count
        'Check if more than 1 row is in the used range.
        If usedRows = 1 Then
            'Since there's only 1 row, see if there's more than 1 cell.
            If .UsedRange.Cells.Count = 1 Then
                'Since there's only 1 cell, check the contents
                If .Cells(1, 1) = "" Then
                      'you're dealing with a blank workbook
                      usedRows = 0
                End If
            End If
        End If
        'Check if range is contigious
        If InStr(r.Address, ",") Then
            For Each c In r.Cells
                .Range(c.Address).Offset(usedRows, 0).Value = c.Value
            Next
        Else
            .Range(r.Address).Offset(usedRows, 0).Value = r.Value
        End If
    End With
    wB.SaveAs filename, xlCSV, , , , False
    wB.Saved = True
    wB.Close
End Sub
Sub Example()
    'I used Selection here just to make it easier to test.
    'Substitute your actual range, and actual desired filepath
    'If you pass false for overwrite, it assumes you want to append
    'It will give you a pop-up asking if you want to overwrite, which I could avoid
    'by copying the worksheet and then closing and deleting the file etc... but I
    'already spent enough time on this one.
    SaveRangeAsCSV Selection, "C:\proofOfConcept.csv", False
End Sub

Wenn es zu benutzen, nur liefern die tatsächliche Reichweite der tatsächliche Dateiname, und ob oder nicht Sie möchten, um die Datei zu überschreiben. 🙂 Dieser wurde aktualisiert, damit die nicht-zusammenhängende Bereiche. Für verbundene Zellen es wird am Ende setzen Sie den Wert in der ersten Zelle in der zusammengeführten Bereich.

InformationsquelleAutor Daniel

Meinen Artikel Erstellen von und Schreiben in eine CSV-Datei mit Excel-VBA

Dieser Artikel enthält zwei VBA-code-Beispiele zum erstellen und zum schreiben in eine CSV-Datei:

1. Erstellen einer CSV Datei mit Open For Output as FreeFile.
2. Erstellen einer CSV-Datei mit dem FileSystemObject-Objekt.

Ich bevorzuge die letztere Methode vor allem, wie ich bin, mit der "FileSystemObject" für die weitere Codierung, zum Beispiel die Verarbeitung aller Dateien in Unterordnern rekursiv (obwohl, die Technik ist nicht in diesem Artikel).

- Code Anmerkungen

Dieser code muss ausgeführt werden, aus einer normalen VBA-Code-Modul. Ansonsten ist der
code wird einen Fehler verursachen, wenn Benutzer versuchen, führen Sie es aus dem "ThisWorkbook"
oder Blech-Code-Bereiche gegeben, die Verwendung von Const.

Es ist erwähnenswert, dass die ThisWorkbook-und Blech-code-Abschnitte
sollte reserviert werden für Ereignis-Codierung nur "normale" VBA ausgeführt werden soll
vom standard-Code-Module.

Bitte beachten Sie, dass für die Zwecke der Beispiel-code, der Datei-Pfad des
CSV-Ausgabe-Datei ist "hard-coded":
C:\test\myfile.csv an der Spitze der code. Wahrscheinlich werden Sie wollen, stellen Sie die output-Datei programmgesteuert, beispielsweise als
Funktion parameter.

Wie bereits erwähnt; Zum Beispiel Zwecke, dieser code SETZT
SPALTEN UND ZEILEN; das heißt, die Ausgabe-Datei enthält eine CSV-Zeile für
jede Spalte in den ausgewählten Bereich. Normalerweise ist die CSV-Ausgabe wäre
row-by-row -, echo-layout auf dem Bildschirm sichtbar, aber ich wollte
zeigen, dass die Generierung der Ausgabe mithilfe von VBA-code liefert
Optionen über das hinaus, was verfügbar ist, zum Beispiel, indem Sie die " Speichern
... CSV-Text-Menü-option.

Code

Const sFilePath = "C:\test\myfile.csv"
Const strDelim = ","

'Option 1
Sub CreateCSV_Output()
Dim ws As Worksheet
Dim rng1 As Range
Dim X
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long

lFnum = FreeFile
Open sFilePath For Output As lFnum

For Each ws In ActiveWorkbook.Worksheets
    'test that sheet has been used
    Set rng1 = ws.UsedRange
    If Not rng1 Is Nothing Then
        'only multi-cell ranges can be written to a 2D array
        If rng1.Cells.Count > 1 Then
            X = ws.UsedRange.Value2
            'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
            For lCol = 1 To UBound(X, 2)
                'write initial value outside the loop
                 strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))
                For lRow = 2 To UBound(X, 1)
                    'concatenate long string & (short string with short string)
                    strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))
                Next lRow
                'write each line to CSV
                Print #lFnum, strTmp
            Next lCol
        Else
            Print #lFnum, IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
        End If
    End If
Next ws

Close lFnum
MsgBox "Done!", vbOKOnly

End Sub

'Option 2
Sub CreateCSV_FSO()
Dim objFSO
Dim objTF
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long

Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile(sFilePath, True, False)

For Each ws In ActiveWorkbook.Worksheets
    'test that sheet has been used
    Set rng1 = ws.UsedRange
    If Not rng1 Is Nothing Then
        'only multi-cell ranges can be written to a 2D array
        If rng1.Cells.Count > 1 Then
            X = ws.UsedRange.Value2
            'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
            For lCol = 1 To UBound(X, 2)
                'write initial value outside the loop
                strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))
                For lRow = 2 To UBound(X, 1)
                    'concatenate long string & (short string with short string)
                    strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))
                Next lRow
                'write each line to CSV
                objTF.writeline strTmp
            Next lCol
        Else
            objTF.writeline IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
        End If
    End If
Next ws

objTF.Close
Set objFSO = Nothing
MsgBox "Done!", vbOKOnly

End Sub

InformationsquelleAutor brettdj