VBA - Save Data in Separate Files

[luckee]

Hi, I have a spreadsheet sorted by column A. I want the macro to split and save everything as a separate CSV file for each month but only include the data from column B to D.

Thanks in advance!

 

[rpaulson]

try this on a copy of your file. be WARNED - this will DELETE all existing csv files in you path!

Sub Create_Txt_File()

On Error Resume Next
myPath = "c:\test\"
Kill myPath & "*.csv" 'this will delete all that file type within that folder
On Error GoTo 0

For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
     Data = Cells(r, "B") & "," & Cells(r, "C") & ","  Cells(r, "D")
    Open myPath & Cells(r, "A") & ".csv" For Append As #1
    Print #1, Data
    Close #1
Next r
 
End Sub

hth,
Ross

 

[luckee]

try this on a copy of your file. be WARNED - this will DELETE all existing csv files in you path!

Sub Create_Txt_File()

On Error Resume Next
myPath = "c:\test\"
Kill myPath & "*.csv" 'this will delete all that file type within that folder
On Error GoTo 0

For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
     Data = Cells(r, "B") & "," & Cells(r, "C") & ","  Cells(r, "D")
    Open myPath & Cells(r, "A") & ".csv" For Append As #1
    Print #1, Data
    Close #1
Next r
 
End Sub

hth,
Ross

Hi Ross, getting "Compile error: Syntax error" on:

Data = Cells(r, "B") & "," & Cells(r, "C") & "," Cells(r, "D")

Thanks.

 

[rpaulson]

oops, for got an ampersand

Data = Cells(r, "B") & "," & Cells(r, "C") & "," & Cells(r, "D")

 

[luckee]

oops, for got an ampersand

Data = Cells(r, "B") & "," & Cells(r, "C") & "," & Cells(r, "D")

Getting a runtime error on

Open myPath & Cells(r, "A") & ".csv" For Append As #1

 

[rpaulson]

try this,

Option Explicit
Sub Create_Txt_File()

Dim mypath As String
Dim data As String
Dim r As Long

On Error Resume Next
mypath = "c:\test\"
Kill mypath & "*.csv" 'this will delete all that file type within that folder
On Error GoTo 0

For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
     data = Cells(r, "B") & "," & Cells(r, "C") & "," & Cells(r, "D")
    Open mypath & Cells(r, "A") & ".csv" For Append As #1
    Print #1, data
    Close #1
Next r
 
End Sub

 

[luckee]

try this,

Option Explicit
Sub Create_Txt_File()

Dim mypath As String
Dim data As String
Dim r As Long

On Error Resume Next
mypath = "c:\test\"
Kill mypath & "*.csv" 'this will delete all that file type within that folder
On Error GoTo 0

For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
     data = Cells(r, "B") & "," & Cells(r, "C") & "," & Cells(r, "D")
    Open mypath & Cells(r, "A") & ".csv" For Append As #1
    Print #1, data
    Close #1
Next r
 
End Sub

Says path not found. I found the below online which separates into new tabs then creates new file but I was hoping this could be combined into one and the tabs be deleted after the CSV files are created

Sub NewSheets()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="1", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear

For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
'Sheets(myarr(i) & "").Columns.AutoFit
Next

ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub

Then I found which saves as new files

Sub NewFiles()

Dim shtS As Worksheet
Dim strPath As String

strPath = ThisWorkbook.Path & "\"

For Each shtS In ThisWorkbook.Worksheets

shtS.Move
ActiveWorkbook.SaveAs strPath & ActiveSheet.Name & Format(Date, "_yymmdd") & ".csv"
ActiveWorkbook.Close False

Next shtS

End Sub

 

[rpaulson]

change
mypath ="c:\test\"
to
mypath = ThisWorkbook.Path & "\"

 

[luckee]

change
mypath ="c:\test\"
to
mypath = ThisWorkbook.Path & "\"

works now, thank you ! one last thing. it didn't carryover the header. how can i add that ?

 

[rpaulson]

Option Explicit
Sub Create_Txt_File()

Dim mypath As String, myfile As String
Dim data As String
Dim r As Long

On Error Resume Next
mypath = "c:\test\"
Kill mypath & "*.csv" 'this will delete all that file type within that folder
On Error GoTo 0

For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
     data = Cells(r, "B") & "," & Cells(r, "C") & "," & Cells(r, "D")
    
     myfile = Cells(r, "A") & ".csv"
    
     If Dir(mypath & myfile) = "" Then 'file does not exist - write the header row
        Open mypath & myfile For Append As #1
        Print #1, [B1] & "," & [C1] & "," & [D1]
        Close #1
    
     End If
    
    Open mypath & myfile For Append As #1
    Print #1, data
    Close #1
Next r
 
End Sub