根據單元格數據自動生成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，我現在需要修改它做兩件事情，一個生成多個CSV的一個對每個唯一的值在A列，然後拉基於從塔B值A列

例如： -

列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