Automatically Generate CSVs based on cell data - vba

Question

I have the following code which generates a csv file.
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
This just pulls the top 4 values from the sheets and puts them in a CSV, I now need to modify it to do 2 things, one generate multiple CSVs one for each unique value in column A and then pull values from column B based on column A.
For example:-
Column A contains set A, set B, set C - Set A has 3 tables in column B and I want this to be copied across to the new CSV but I want this to happen for all the sets automatically.
Any help would be greatly appreciated, even a point to another answer?

Answer 1

I am assuming that you want to Print the contents of each Table to the associated Set.
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
Update: You don't need the more complex example but I am going to leave it. It may be helpful to future viewers.
Cahnge these variables
SouceWorkSheet: The name of the worksheet that your list is on
KillOldFiles: Do you want to delete the old files
arColumns = Array(1, 2, 9, 10): Add the column numbers that you want to export to this array. You just nned to use 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

Can't you use something like this ?
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