有沒有辦法將批量範圍寫入文本/ CSV文件？

Question

我以前寫的單元格區域的內容（值）與在VBA中寫命令的文本文件，例如：

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

是否存在一個更優雅和方便的內置-in方法將整個範圍直接轉儲到分隔文件，甚至可能一次覆蓋多行？還是有人提出了一個定製的解決方案？我認爲這會非常有用。

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 

簡短而親切！ ;）

儘管如此，我仍然給丹尼爾庫克的解決方案，這也是非常有用的信用它應得的。

Answer 3

從我的文章Creating and Writing to a CSV FIle using Excel VBA

本文提供了兩個VBA代碼示例創建並寫入到CSV文件：

1. 創建使用開放輸出FreeFile CSV文件。
2. 使用FileSystemObject對象創建CSV文件。

我更喜歡後一種方法，主要是因爲我正在使用FileSystemObject進行進一步編碼，例如遞歸處理子文件夾中的所有文件（儘管本文中未使用該技術）。

代碼註釋

此代碼必須從一個普通VBA代碼模塊中運行。否則， 代碼將導致錯誤，如果用戶嘗試從給定Const的用法的ThisWorkbook 或Sheet Code窗格運行它。

值得注意的是，ThisWorkbook和Sheet代碼部分 應該只保留用於事件編碼，「標準」VBA應該從標準代碼模塊運行 。

請注意，出於示例代碼的目的， CSV輸出文件的文件路徑是「硬編碼」的： C：\ test \ myfile.csv位於代碼的頂部。您可能希望以編程方式設置輸出文件，例如作爲 函數參數。

如前所述;出於示例目的，此代碼TRANSPOSES COLUMNS AND ROWS;也就是說，輸出文件包含一個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 

Answer 4

這些方法上方橫跨單元格區域迭代以導出數據。由於所有的錯誤檢查，任何通過循環遍歷表格中一系列單元格的操作都非常緩慢。

這是我沒有迭代的方法。基本上，它使用內置函數「Join（）」來完成繁重的工作，這將是您的迭代循環。這要快得多。

的相關閱讀（）子程序我在另一個帖子詳細介紹：https://stackoverflow.com/a/35688988/2800701

這是寫（）子程序（注：這是假定你的文字是預格式化工作表中的正確規範然後再導出它;它只能在單列上工作...不在多列範圍內）：

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