Forum Discussion
Modify macro for CSV
I have this code, it will create one .csv file with header and row for each row in a table.
I copies from another place and did some minor modifications, now what I need is to add a way so the macro will name each file based on the 4th column per row, and not just add numbers, if anyone can help do that I would appreciate, thanks.
Also im trying to figure a way to make the macro write in the actual directory that the file .xlsm is placed
Sub SaveCSVfiles()
Dim last_row As Long
last_row = Cells.Find(What:="*", SearchDirection:=xlPrevious).Row
Const NumRows As Integer = 1
Const HeaderRow As Integer = 1
Const FolderPath As String = "C:\Users\activeuser\Desktop\Test\" 'change to suit
Dim iRow As Integer, startSheet As Worksheet, tmpSheet As Worksheet
Application.ScreenUpdating = False
iRow = HeaderRow + 1
Set startSheet = ActiveSheet
Do Until iRow > last_row + HeaderRow
Set tmpSheet = Worksheets.Add
'copy the header
startSheet.Range(HeaderRow & ":" & HeaderRow).EntireRow.Copy tmpSheet.Range("A1")
'copy the data
startSheet.Range(iRow & ":" & (iRow + NumRows - HeaderRow)).EntireRow.Copy tmpSheet.Range("A2")
'save tmpSheet to CSV file
tmpSheet.Move
With ActiveWorkbook
.SaveAs Filename:=FolderPath & (iRow + NumRows - HeaderRow - 1) & ".csv", FileFormat:=xlCSVMSDOS
.Close True
End With
iRow = iRow + NumRows
Loop
Application.ScreenUpdating = True
End Sub
Adjusted your code a little bit. You need to include your variables "sWorkbookPath" and "fName" in the code that saves the workbook. But before that, you must pick-up the file name within the loop, so that it starts with A2, then A3, then A4 etc.
See if you can get it to work. If not, come back!
Sub SaveCSVfiles() Dim last_row As Long last_row = Cells.Find(What:="*", SearchDirection:=xlPrevious).Row Dim sWorkbookPath As String Dim fName As String sWorkbookPath = ActiveWorkbook.Path MsgBox "Active Workbook Path is : " & sWorkbookPath, vbInformation, "VBAF1" Const NumRows As Integer = 1 Const HeaderRow As Integer = 1 Dim iRow As Integer, startSheet As Worksheet, tmpSheet As Worksheet Application.ScreenUpdating = False iRow = HeaderRow + 1 Set startSheet = ActiveSheet Do Until iRow > last_row + HeaderRow Set tmpSheet = Worksheets.Add fName = startSheet.Range("A" & iRow) 'copy the header startSheet.Range(HeaderRow & ":" & HeaderRow).EntireRow.Copy tmpSheet.Range("A1") 'copy the data startSheet.Range(iRow & ":" & (iRow + NumRows - HeaderRow)).EntireRow.Copy tmpSheet.Range("A2") 'save tmpSheet to CSV file tmpSheet.Move With ActiveWorkbook .SaveAs Filename:=sWorkbookPath & fName & (iRow + NumRows - HeaderRow - 1) & ".csv", FileFormat:=xlCSVMSDOS .Close True End With iRow = iRow + NumRows Loop Application.ScreenUpdating = True End Sub
5 Replies
To include 4th column header in the file name you need to declare a variable first. For example:
Dim fName as String
Then you have to read out the value of the header and assign it to the fName. This could be something like this:
fName = Range("D1")
Then you insert fName into the code where the file is being saved. For instance:
.SaveAs Filename:=FolderPath & fName & etc.....Change the folder path to where you want to save the CSV file or leave it out if you want to save it into your current active folder, i.e. the folder from which you opened your workbook. That should work, I believe.
Now, having said all of this, I have not been able to test any of it, since I don't have your file. Try tweaking the code along these lines and just test it yourself.
This is a modified version of the file to protect sensitive information. The name of each file should be A column. I am trying but it keeps trowing all the files in document folder and also it names all files with number, 1,2,3,4.....
Adjusted your code a little bit. You need to include your variables "sWorkbookPath" and "fName" in the code that saves the workbook. But before that, you must pick-up the file name within the loop, so that it starts with A2, then A3, then A4 etc.
See if you can get it to work. If not, come back!
Sub SaveCSVfiles() Dim last_row As Long last_row = Cells.Find(What:="*", SearchDirection:=xlPrevious).Row Dim sWorkbookPath As String Dim fName As String sWorkbookPath = ActiveWorkbook.Path MsgBox "Active Workbook Path is : " & sWorkbookPath, vbInformation, "VBAF1" Const NumRows As Integer = 1 Const HeaderRow As Integer = 1 Dim iRow As Integer, startSheet As Worksheet, tmpSheet As Worksheet Application.ScreenUpdating = False iRow = HeaderRow + 1 Set startSheet = ActiveSheet Do Until iRow > last_row + HeaderRow Set tmpSheet = Worksheets.Add fName = startSheet.Range("A" & iRow) 'copy the header startSheet.Range(HeaderRow & ":" & HeaderRow).EntireRow.Copy tmpSheet.Range("A1") 'copy the data startSheet.Range(iRow & ":" & (iRow + NumRows - HeaderRow)).EntireRow.Copy tmpSheet.Range("A2") 'save tmpSheet to CSV file tmpSheet.Move With ActiveWorkbook .SaveAs Filename:=sWorkbookPath & fName & (iRow + NumRows - HeaderRow - 1) & ".csv", FileFormat:=xlCSVMSDOS .Close True End With iRow = iRow + NumRows Loop Application.ScreenUpdating = True End Sub
