3

私は、VBAのwriteコマンドを使用して、セルの範囲のコンテンツ（値）をテキストファイルに書き込むために使用されます。次に例を示します。

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

範囲全体を区切られたファイルに直接ダンプする、よりエレガントで便利な組み込みの方法がありますか？おそらく一度に複数の行にまたがる場合もありますか？または、誰かがカスタマイズされたソリューションを思いついたことがありますか？それは信じられないほど便利だと思います。

4

4 に答える 4

5

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.

于 2012-10-25T21:20:07.843 に答える
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

短くて甘い！;）

それでも、私はダニエル・クックのソリューションを提供しています。これは、それに値するクレジットにも非常に役立ちます。

于 2012-10-25T22:01:25.127 に答える
1

上記のこれらのメソッドは、データをエクスポートするためにセル範囲全体で繰り返されます。シート内のセルの範囲をループする傾向があるものはすべて、すべてのエラーチェックのために非常に遅くなります。

これが私が反復なしでそれをした方法です。基本的には、組み込み関数「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
于 2016-02-28T22:29:00.000 に答える
0

私の記事からExcelVBAを使用したCSVファイルの作成と書き込み

この記事では、CSVファイルを作成して書き込むための2つのVBAコードサンプルを提供します。

  1. OpenForOutputをFreeFileとして使用してCSVファイルを作成します。
  2. FileSystemObjectオブジェクトを使用してCSVファイルを作成します。

私は主に後者のアプローチを好みます。たとえば、サブフォルダー内のすべてのファイルを再帰的に処理するなど、さらなるコーディングにFileSystemObjectを使用しているためです（ただし、この手法はこの記事では使用されていません）。

コードノート

このコードは、通常のVBAコードモジュールから実行する必要があります。そうしないと、ユーザーがConstの使用法を指定してThisWorkbookまたはSheet Codeペインからコードを実行しようとすると、コードでエラーが発生します。

ThisWorkbookセクションとSheetコードセクションはイベントコーディング専用に予約する必要があり、「通常の」VBAは標準のコードモジュールから実行する必要があることに注意してください。

サンプルコードの目的上、CSV出力ファイルのファイルパスは、コードの上部にあるC：\ test\myfile.csvのように「ハードコード」されていることに注意してください。たとえば、関数パラメータとして、プログラムで出力ファイルを設定することをお勧めします。

先に述べたように; 例として、このコードは列と行を転置します。つまり、出力ファイルには、選択した範囲の列ごとに1つの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
于 2012-10-25T23:41:55.560 に答える