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中，我现在需要修改它以执行2项操作，一个为A列中的每个唯一值生成多个CSV，然后从列B中提取值基于A栏。

例如： -

A列包含集合A，集合B，集合C - 集合B在B列中有3个表格，我希望将其复制到新的CSV中，但我希望自动对所有集合进行此操作。

任何帮助都会受到高度赞赏，甚至是另一个答案？

Answer 1

你不能用这样的东西吗？

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

Answer 2

我假设你想打印每个表的内容到关联的设置。

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

更新：你不需要更复杂的例子，但我会离开它。它可能对未来的观众有所帮助。

改变这些变量

SouceWorkSheet：列表所在的工作表的名称
KillOldFiles：是否要删除旧文件
arColumns = Array（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

根据单元格数据自动生成CSV

2 个答案: