我习惯使用VBA中的write命令将一系列单元格的内容（值）写入文本文件，例如：
write #myfile, Range("A1").value, Range("A2).value, Range("A3).value
是否存在更优雅和方便的内置方法将整个范围直接转储到分隔文件，甚至可能一次多个行？或者有人提出定制的解决方案吗？我认为这将非常有用。
答案 0 :(得分：4)
我写信给你，它仍然可以改进，但我认为它已经足够好了：
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
使用它时，只提供实际范围，实际文件名以及是否要覆盖该文件。 :)已更新以允许非连续范围。对于合并的单元格，它最终会将值放在合并范围的第一个单元格中。
答案 1 :(得分：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
简短又甜蜜！ ;）
我仍然在给予丹尼尔库克的解决方案，这也是它应得的信誉非常有用。
答案 2 :(得分：0)
从我的文章Creating and Writing to a CSV FIle using Excel VBA
本文提供了两个VBA代码示例来创建和写入CSV文件：
我更喜欢后一种方法，因为我使用FileSystemObject进行进一步编码，例如递归处理子文件夹中的所有文件（尽管本文中未使用该技术）。
代码备注
此代码必须从常规VBA代码模块运行。否则 如果用户尝试从ThisWorkbook运行它，代码将导致错误 或者使用Const。
的工作表代码窗格值得注意的是ThisWorkbook和Sheet代码部分 应仅为事件编码保留，应运行“正常”VBA 来自标准代码模块。
请注意，出于示例代码的目的，该文件的路径 CSV输出文件被“硬编码”为： 代码顶部的C：\ test \ myfile.csv。您可能希望以编程方式设置输出文件，例如a 功能参数。
如前所述;例如，此代码为TRANSPOSES 栏目和行;也就是说，输出文件包含一个CSV行 所选范围内的每一列。通常，CSV输出将是 逐行，回显屏幕上可见的布局，但我想 演示通过使用VBA代码生成输出 超出可用范围的选项，例如，使用Save 作为... 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
答案 3 :(得分：0)
以上这些方法遍历单元格范围以便导出数据。由于所有错误检查，任何与在工作表中的一系列单元格上循环有关的事情都非常缓慢。
这是我没有迭代的方式。基本上，它使用内置函数“Join（）”来完成繁重的操作，这将是您的迭代循环。这要快得多。
我在另一篇帖子中详述的相关 Read（）子例程：https://stackoverflow.com/a/35688988/2800701
这是 Write（）子例程（注意：这假设您的文本在导出之前已预先格式化为工作表中的正确规范;它只能在单个列上工作.. .not在多个列范围内）：
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