vba 有没有办法将范围批量写入文本/CSV 文件？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/13077317/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Is there a way to write ranges in bulk to a text/CSV file?
提问by Steve06
I'm used to write the content (values) of a range of cells to a text file with the write command in VBA, for example:
我习惯于使用 VBA 中的 write 命令将一系列单元格的内容（值）写入文本文件，例如：
write #myfile, Range("A1").value, Range("A2).value, Range("A3).value
write #myfile, Range("A1").value, Range("A2).value, Range("A3).value
Does there exist a more elegant and convenient built-in method to dump a whole range directly to a delimited file, possibly even over multiple rows at a time? Or has anybody come up with a customized solution? I think that would be incredibly useful.
是否存在更优雅和方便的内置方法将整个范围直接转储到分隔文件，甚至可能一次转储多行？或者有人提出了定制的解决方案？我认为这将非常有用。
回答by Daniel
I wrote you this it could still be improved, but I think it's good enough:
我给你写了这个它仍然可以改进，但我认为它已经足够好了：
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
When using it, just supply the actual range, the actual filename, and whether or not you want to overwrite the file. :) This has been updated to allow non-contiguous ranges. For merged cells it will end up putting the value in the first cell of the merged range.
使用时，只需提供实际范围、实际文件名以及是否要覆盖文件。:) 这已更新为允许非连续范围。对于合并的单元格，它最终会将值放在合并范围的第一个单元格中。
回答by Steve06
This is the solution I came up with by myself and suits my needs best as far as I can see:
这是我自己提出的解决方案，据我所知最适合我的需求：
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
Short and sweet! ;)
又短又甜！;)
Still I'm giving Daniel Cook's solution which is also very useful the credit it deserves.
我仍然给予 Daniel Cook 的解决方案，这也非常有用，值得称赞。
回答by RexBarker
These methods above iterate across the cell ranges in order to export the data. Anything that tends to do with looping over a range of cells in the sheet is extremely slow due to all the error checking.
上述这些方法遍历单元格范围以导出数据。由于所有错误检查，任何倾向于循环工作表中一系列单元格的操作都非常慢。
Here's a way I did it without the iteration. Basically, it makes use of the built in function "Join()" to do the heavy lifting which would be your iteration loop. This is much faster.
这是我在没有迭代的情况下做到的一种方式。基本上，它利用内置函数“Join()”来完成繁重的迭代循环。这要快得多。
The related Read()subroutine I detailed in another posting: https://stackoverflow.com/a/35688988/2800701
我在另一篇文章中详细介绍了相关的Read()子程序：https: //stackoverflow.com/a/35688988/2800701
This is the Write()subroutine (note: this assumes your text is pre-formatted to the correct specification in the worksheet before you export it; it will only work on a single column...not on multiple column ranges):
这是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
回答by brettdj
From my article Creating and Writing to a CSV FIle using Excel VBA
从我的文章使用 Excel VBA 创建和写入 CSV 文件
This Article provides two VBA code samples to create and write to a CSV file:
本文提供了两个 VBA 代码示例来创建和写入 CSV 文件：
- Creating a CSV file using the Open For Output as FreeFile.
- Creating a CSV file using the FileSystemObject object.
- 使用 Open For Output as FreeFile 创建 CSV 文件。
- 使用 FileSystemObject 对象创建 CSV 文件。
I prefer the latter approach mainly as I am using the FileSystemObject for further coding, for example processing all files in subfolders recursively (though that technique is not used in this article).
我更喜欢后一种方法，主要是因为我使用 FileSystemObject 进行进一步编码，例如递归处理子文件夹中的所有文件（尽管本文未使用该技术）。
Code Notes
代码注释
This code must be run from a regular VBA Code Module. Otherwise the code will cause an error if users try to run it from the ThisWorkbook or Sheet Code panes given the usage of Const.
It is worth noting that the ThisWorkbook and Sheet code sections should be reserved for Event coding only, "normal" VBA should be run from standard Code Modules.
Please note that for purposes of the sample code, the file path of the CSV output file is "hard-coded" as: C:\test\myfile.csv at the top of the code. You will probably want to set the output file programmatically, for instance as a function parameter.
As mentioned earlier; For example purposes, this code TRANSPOSES COLUMNS AND ROWS; that is, the output file contains one CSV row for each column in the selected range. Normally, CSV output would be row-by-row, echoing the layout visible on screen, but I wanted to demonstrate that generating the output by using VBA code provides options beyond what is available by, for instance, using the Save As... CSV Text menu option.
此代码必须从常规 VBA 代码模块运行。否则，如果用户尝试从 ThisWorkbook 或 Sheet Code 窗格中运行它，代码将导致错误，因为使用了 Const。
值得注意的是，ThisWorkbook 和 Sheet 代码部分应仅用于事件编码，“正常”VBA 应从标准代码模块运行。
请注意，出于示例代码的目的，CSV 输出文件的文件路径被“硬编码”为：代码顶部的 C:\test\myfile.csv。您可能希望以编程方式设置输出文件，例如作为函数参数。
如前面提到的; 例如，此代码 TRANSPOSES COLUMNS AND ROWS; 也就是说，输出文件为所选范围内的每一列包含一个 CSV 行。通常，CSV 输出将是逐行的，与屏幕上可见的布局相呼应，但我想证明使用 VBA 代码生成输出提供了超出可用选项的选项，例如，使用另存为... CSV 文本菜单选项。
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
