セルデータに基づいてCSVを自動的に生成

Question

私はcsvファイルを生成する次のコードを持っています。

Sub WriteCSVFile() 

    Dim My_filenumber As Integer 
    Dim logSTR As String 

    My_filenumber = FreeFile 

    logSTR = logSTR & Cells(1, "A").Value & " , " 
    logSTR = logSTR & Cells(2, "A").Value & " , " 
    logSTR = logSTR & Cells(3, "A").Value & " , " 
    logSTR = logSTR & Cells(4, "A").Value 

    Open "D:\BIG DATA\VBA\Sample.csv" For Append As #My_filenumber 
     Print #My_filenumber, logSTR 
    Close #My_filenumber 

End Sub 

これは単なるシートから、トップ4の値を引くと、CSVでそれらを置く、私は今1は、複数のCSVに列Aの各一意の値のための1つを生成し、引き、2つのことを行うには、それを修正する必要があります列Bの値は、例えば、列A

に基づく： -

列Aは、セットB、セットCを設定含ま - セットAは、列B中の3つのテーブルを持っており、これはに渡ってコピーしたいです新しいCSVですが、これはすべてのセットに対して自動的に発生します。

ご協力いただければ幸いです。また、別の回答への回答がありますか？

Answer 1

私はあなたが印刷関連する設定に各表の内容にしたいと仮定しています。

Sub WriteCSVFile2() 
    Const RootPath As String = "C:\Data Files\Sample_" 
    Const KillOldFiles As Boolean = True 
    Dim My_filenumber As Integer 
    Dim FileName As String 
    Dim rw As Range 
    Dim tbls As Collection 
    Dim tbl As ListObject 
    Set tbls = getAllTables 

    My_filenumber = FreeFile 

    If KillOldFiles Then 
     For Each rw In Sheet1.ListObjects("SourceTable").DataBodyRange.Rows 
      FileName = RootPath & rw.Cells(1, 1) & ".csv" 
      If Len(Dir(FileName)) Then Kill FileName 
     Next 
    End If 

    For Each rw In Sheet1.ListObjects("SourceTable").DataBodyRange.Rows 
     FileName = RootPath & rw.Cells(1, 1) & ".csv" 
     Debug.Print FileName 
     On Error Resume Next 
     Set tbl = tbls.Item(rw.Cells(1, 2)) 

     If Not tbl Is Nothing Then 
      Open FileName For Append As #My_filenumber 

      Print #My_filenumber, getDataBodyRangeCSV(tbl) 

      Close #My_filenumber 
     End If 

     Set tbl = Nothing 
     On Error GoTo 0 

    Next 

End Sub 

Function getDataBodyRangeCSV(tbl As ListObject) As String 
    Dim c As Range, rw As Range 
    Dim tr As String, result As String 
    For Each rw In tbl.DataBodyRange.Rows 
     For Each c In rw.Cells 
      tr = tr & c.value & "," 
     Next 
     result = result & Left(tr, Len(tr) - 1) & vbCrLf 
     tr = "" 
    Next 
    getDataBodyRangeCSV = Left(result, Len(result) - 1) 
End Function 

Function getAllTables() As Collection 
    Dim lists As Collection 
    Dim tbl As ListObject 
    Dim ws As Worksheet 
    Set lists = New Collection 
    For Each ws In ThisWorkbook.Worksheets 
     For Each tbl In ws.ListObjects 
      On Error Resume Next 
      lists.Add tbl, tbl.Name 

      On Error GoTo 0 
     Next 
    Next 
    Set getAllTables = lists 
End Function 

---

更新：あなたは、より複雑な例を必要としませんが、私はそれを残すつもりです。今後の視聴者にとっては役に立つかもしれません。

Cahngeにこれらの変数

• SouceWorkSheet：あなたのリストは

• KillOldFiles上にあるワークシートの名前：あなたは古いファイル

• arColumnsを削除しますか=アレイ（ 1、2、9、10）：この配列にエクスポートする列番号を追加します。あなたはちょうどWriteCSVFile3を使用することを望んだ。

---

Sub WriteCSVFile3() 
    Const SouceWorkSheet As String = "Source" 
    Const RootPath As String = "C:\Data Files\Sample_" 
    Const KillOldFiles As Boolean = True 
    Dim My_filenumber As Integer 
    Dim FileName As String, tr As String 
    Dim lastRow As Long, x As Long, y 
    Dim arColumns As Variant 

    arColumns = Array(1, 2, 9, 10) 

    My_filenumber = FreeFile 

    With Worksheets(SouceWorkSheet) 
     lastRow = .Range("A" & Rows.Count).End(xlUp).Row 
     If KillOldFiles Then 
      For x = 2 To lastRow 
       FileName = RootPath & .Cells(x, 1) & ".csv" 
       If Len(Dir(FileName)) Then Kill FileName 
      Next 
     End If 

     For x = 2 To lastRow 
      FileName = RootPath & .Cells(x, 1) & ".csv" 
      Open FileName For Append As #My_filenumber 
      For y = 0 To UBound(arColumns) 
       tr = tr & .Cells(x, arColumns(y)).value & "," 
      Next 

      Print #My_filenumber, Left(tr, Len(tr) - 1) 
      Close #My_filenumber 
      tr = "" 
     Next 

    End With 

End Sub 

Answer 2

あなたはこのようなものを使用することができませんか？

Dim OutputFileNum As Integer  
OutputFileNum = FreeFile 

Open "file.csv" For Output Lock Write As #OutputFileNum 

Print #OutputFileNum, "Field1" & "," & "Field2" 

SheetValues = Sheets("Sheet1").Range("A1:H9").Value 


Dim LineValues() As Variant 
ReDim LineValues(1 To 2) 

For RowNum = 1 To 9 
    For ColNum = 1 To 2 
     LineValues(ColNum) = SheetValues(RowNum, ColNum) 
    Next 
    Line = Join(LineValues, ",") 
    Print #OutputFileNum, Line 
Next 

Close OutputFileNum