excel - 有没有办法将范围批量写入文本/CSV 文件？

Question

我习惯使用 VBA 中的 write 命令将一系列单元格的内容（值）写入文本文件，例如：

write #myfile, Range("A1").value, Range("A2).value, Range("A3).value

是否存在更优雅和方便的内置方法将整个范围直接转储到分隔文件，甚至可能一次转储多行？或者有没有人想出一个定制的解决方案？我认为这将非常有用。

Answer 1

我给你写了这个它仍然可以改进，但我认为它已经足够好了：

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

使用它时，只需提供实际范围、实际文件名以及是否要覆盖文件。:) 这已更新为允许不连续的范围。对于合并的单元格，它最终会将值放在合并范围的第一个单元格中。

Answer 2

这是我自己提出的解决方案，据我所知最适合我的需求：

Sub DumpRangeToTextFile(filehandle As Integer, source As Range)
Dim row_range As Range, mycell As Range
For Each row_range In source.rows
    For Each mycell In row_range.cells
        Write #filehandle, mycell.Value;
    Next mycell
    Write #filehandle,
Next row_range
End Sub

又短又甜！;)

我仍然给予 Daniel Cook 的解决方案，这也是它应得的功劳。

Answer 3

上面的这些方法遍历单元格范围以导出数据。由于所有错误检查，任何与循环工作表中的一系列单元格有关的事情都非常慢。

这是我在没有迭代的情况下做到的一种方式。基本上，它利用内置函数“Join()”来完成繁重的工作，这将是您的迭代循环。这要快得多。

我在另一篇文章中详述的相关Read()子例程： https ://stackoverflow.com/a/35688988/2800701

这是Write()子例程（注意：这假定您的文本在导出之前已在工作表中预先格式化为正确的规范；它仅适用于单个列...而不适用于多个列范围）：

Public Sub WriteRangeAsPlainText(ExportRange As Range, Optional textfilename As Variant)
   If IsMissing(textfilename) Then textfilename = Application.GetSaveAsFilename(FileFilter:="Text Files (*.txt), *.txt")
   If textfilename = "" Then Exit Sub

   Dim filenumber As Integer
   filenumber = FreeFile
   Open textfilename For Output As filenumber

   Dim textlines() As Variant, outputvar As Variant

   textlines = Application.Transpose(ExportRange.Value)
   outputvar = Join(textlines, vbCrLf)
   Print #filenumber, outputvar
   Close filenumber
End Sub

Answer 4

从我的文章使用 Excel VBA 创建和写入 CSV 文件

本文提供了两个 VBA 代码示例来创建和写入 CSV 文件：

1. 使用 Open For Output as FreeFile 创建 CSV 文件。
2. 使用 FileSystemObject 对象创建 CSV 文件。

我更喜欢后一种方法，主要是因为我使用 FileSystemObject 进行进一步编码，例如递归处理子文件夹中的所有文件（尽管本文中没有使用该技术）。

代码注释

此代码必须从常规 VBA 代码模块运行。否则，如果用户在使用 Const 的情况下尝试从 ThisWorkbook 或 Sheet Code 窗格运行该代码，则会导致错误。

值得注意的是，ThisWorkbook 和 Sheet 代码部分应仅保留用于事件编码，“正常”VBA 应从标准代码模块运行。

请注意，出于示例代码的目的，CSV 输出文件的文件路径被“硬编码”为：代码顶部的 C:\test\myfile.csv。您可能希望以编程方式设置输出文件，例如作为函数参数。

如前面提到的; 例如，此代码转置列和行；也就是说，输出文件包含所选范围内每一列的一个 CSV 行。通常，CSV 输出将是逐行的，与屏幕上可见的布局相呼应，但我想证明使用 VBA 代码生成输出提供的选项超出了可用的选项，例如，使用另存为... CSV 文本菜单选项。

代码

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