Save batch files as csv from excel.
VBA separates one Excel sheet of data into separate files, after every 833th row.
Now I need these files to be csvs and not Excels. How can I save directly to .csv (separated by comma) files?
I have made appropriate VBA to save into Excel (xml), but not csvs. I need CSVs.
Sub Macro1()
Dim rLastCell As Range
Dim rCells As Range
Dim strName As String
Dim lLoop As Long, lCopy As Long
Dim wbNew As Workbook
With ThisWorkbook.Sheets(1)
Set rLastCell = .Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious)
For lLoop = 1 To rLastCell.Row Step 833
lCopy = lCopy + 1
Set wbNew = Workbooks.Add
.Range(.Cells(lLoop, 1), .Cells(lLoop + 833, .Columns.Count)).EntireRow.Copy _
Destination:=wbNew.Sheets(1).Range("A1")
wbNew.Close SaveChanges:=True, Filename:="Chunk" & lCopy & "Rows" & lLoop & "-" & lLoop + 833
Next lLoop
End With
End Sub
Actual results: Excels
Expected results: CSV files
Something like this?
Sub CSVQuotes()
Dim SrcRange As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSeparator As String
Dim FileName As Variant
Dim current As String
FileName = Application.GetSaveAsFilename()
ListSeparator = ";"
Set SrcRange = Sheets("DATI").UsedRange
Open FileName For Output As #1
For Each CurrRow In SrcRange.Rows
CurrTextStr = ""
For Each CurrCell In CurrRow.Cells
current = CurrCell
CurrTextStr = CurrTextStr & """" & current & """" & ListSeparator
Next
While Right(CurrTextStr, 1) = ListSeparator
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
Print #1, CurrTextStr
Next
Close #1
Assuming:
strPath = path to target folder
autoIncrement = variable to increment every loop (so we can differentiate the files names)
strRow = string representing 1 row in the CSV; concatenate all columns of each Excel row, alternating values with separator (",")
You can output CSV with this inside a loop:
Open strPath & "\file-" & autoIncrement & ".csv" For Output As #fileNumber
Print #fileNumber, strRow
Close #fileNumber
Related
I have made the following code where the aim is to save two ranges into a CSV file:
Sub Export_range_to_CSV()
Dim myCSVFileName As String
Dim myWB As Workbook
Dim tempWB As Workbook
Dim range1 As Range
Dim range2 As Range
Set range1 = Sheets("sheet1").Range("G2:G4")
Set range2 = Sheets("sheet1").Range("G5:H53")
Application.DisplayAlerts = False
On Error GoTo err
Set myWB = ThisWorkbook
myCSVFileName = "filepath" & "\" & "name" & VBA.Format(VBA.Now, "yyyymmdd_hhmm") & ".csv"
range1.Copy
Set tempWB = Application.Workbooks.Add(1)
With tempWB
.Sheets(1).Range("A1").PasteSpecial xlPasteValues
range2.Copy
.Sheets(1).Range("A4").PasteSpecial xlPasteValues
.SaveAs Filename:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
err:
Application.DisplayAlerts = True
End Sub
The code above does the job, but for range1 it has commas at the end of the string when saved as CSV. I need to remove these in order for a job downstream to work. How do I get rid of the commas at the end of range1?
This is how it looks once saved as the CSV file:
range1
- # X=Y, <- need to remove these commas
- # Z=U,
- # M=Q,
range2
- datetime,quantity
- 2021-03-05 23:00:00+00:00,17
- 2021-03-05 23:30:00+00:00,17
- 2021-03-06 00:00:00+00:00,17
- 2021-03-06 00:30:00+00:00,17
I think the problem comes from range1 only having a single column and as soon as range2 comes into play it assumes range1 should be two columns as well.
The last column is calculated by checking the last column of both the ranges. Whichever is higher will be taken. Let me explain it.
Let's say the data is till column J
Set range1 = Sheets("sheet1").Range("G2:G4")
Set range2 = Sheets("sheet1").Range("G5:J53")
Then in this scenario, there will be 3 commas added. Similarly if the last column is K in range2 and last column is H in range1 then there will be 3 commas added to the 1st range.
The same holds true when you reverse the range
Set range1 = Sheets("sheet1").Range("G5:J53")
Set range2 = Sheets("sheet1").Range("G2:G4")
Now the 2nd range will have extra commas
Solution
Read the data in an array and then remove the last comma. So once your Csv file is written, pass the file to this procedure and it will take care of the rest
The below code reads the csv in an array in one go and then checks every line if it has a , on the right. And if it has then it removes it. Finally it deletes the old csv and writes the new file by putting the array in the text file in one go. I have commented the code so you should not have a problem understanding it. But if you do then simply ask.
'~~> Example usage
Sub Sample()
CleanCsv "C:\Users\Siddharth Rout\Desktop\aaa.txt"
End Sub
'~~> Cleans csv
Sub CleanCsv(fl As String)
Dim MyData As String, strData() As String
Dim i As Long
'~~> Read the file in one go into an array
Open fl For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'~~> Check for "," and remove
For i = LBound(strData) To UBound(strData)
If Right(strData(i), 1) = "," Then
Do While Right(strData(i), 1) = ","
strData(i) = Left(strData(i), Len(strData(i)) - 1)
Loop
End If
Next i
'~~> Kill old file
Kill fl
'~~> Output the array in one go into a text file
Dim ff As Long
ff = FreeFile
Open fl For Binary As #ff
Put #ff, , Join(strData, vbCrLf)
Close #ff
End Sub
Remove Trailing Comma
You run exportRangesToCSV, while removeTrailingCommaInTextFile is being called near the end, and removeTrailingComma is being called by removeTrailingCommaInTextFile.
I tested it and it works, but keep in mind that I know very little about manipulating text files (2nd procedure) and that this is more or less the first Regex I've ever written (3rd procedure). It took me 'ages' to write them (not complaining). The 1st procedure is where I'm 'at home'.
Note the example of a classic error-handling routine in the 2nd procedure (yours is unacceptable: you're missing the Resume part). You could easily apply it to the 1st procedure.
Don't forget to adjust the values in the constants section.
The Code
Option Explicit
Sub exportRangesToCSV()
Const sName As String = "Sheet1"
Const sAddr As String = "G2:G4,G5:H53"
Const dFolderPath As String = "C:\Test"
Const dLeftBaseName As String = "Name"
Const dTimeFormat As String = "yyyymmdd_hhmm"
Const dFileExtension As String = ".csv"
Const dAddr As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim rg As Range: Set rg = wb.Worksheets(sName).Range(sAddr)
Dim dFilePath As String
dFilePath = dFolderPath & "\" & dLeftBaseName _
& VBA.Format(VBA.Now, dTimeFormat) & dFileExtension
Application.ScreenUpdating = False
With Workbooks.Add()
Dim dCell As Range: Set dCell = .Worksheets(1).Range(dAddr)
Dim srg As Range
For Each srg In rg.Areas
dCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
Set dCell = dCell.Offset(srg.Rows.Count)
Next srg
Application.DisplayAlerts = False
.SaveAs dFilePath, xlCSV
Application.DisplayAlerts = True
.Close False
End With
Application.ScreenUpdating = True
removeTrailingCommaInTextFile dFilePath, True
'wb.FollowHyperlink dFolderPath
End Sub
Sub removeTrailingCommaInTextFile( _
ByVal FilePath As String, _
Optional ByVal removeAllOccurrences As Boolean = False)
Const ProcName As String = "removeTrailingCommaInTextFile"
On Error GoTo clearError
Dim TextFile As Long: TextFile = FreeFile
Dim TempString As String
Open FilePath For Input As TextFile
TempString = Input(LOF(TextFile), TextFile)
Close TextFile
Open FilePath For Output As TextFile
Print #TextFile, removeTrailingComma(TempString, removeAllOccurrences)
Close TextFile
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & err.Number & "':" & vbLf _
& " " & err.Description
Resume ProcExit
End Sub
Function removeTrailingComma( _
ByVal SearchString As String, _
Optional ByVal removeAllOccurrences As Boolean = False) _
As String
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
If removeAllOccurrences Then
.Pattern = ",+$"
Else
.Pattern = ",$"
End If
removeTrailingComma = .Replace(SearchString, "")
End With
End Function
Edit
This solution will write directly to the text file without exporting. It may become slow if there are too many cells.
Arrays
Sub exportRangesToCSVArrays()
Const sName As String = "Sheet1"
Const sAddr As String = "G2:G4,G5:H53"
Const dFolderPath As String = "C:\Test"
Const dLeftBaseName As String = "Name"
Const dTimeFormat As String = "yyyymmdd_hhmm"
Const dFileExtension As String = ".csv"
Const dAddr As String = "A1"
Const Delimiter As String = ","
Dim wb As Workbook: Set wb = ThisWorkbook
Dim rg As Range: Set rg = wb.Worksheets(sName).Range(sAddr)
Dim aCount As Long: aCount = rg.Areas.Count
Dim Data As Variant: ReDim Data(1 To aCount)
Dim rData() As Long: ReDim rData(1 To aCount)
Dim cData() As Long: ReDim cData(1 To aCount)
Dim OneCell As Variant: ReDim OneCell(1 To 1, 1 To 1)
Dim srg As Range
Dim srCount As Long, scCount As Long
Dim drCount As Long, dcCount As Long
Dim n As Long
For Each srg In rg.Areas
n = n + 1
srCount = srg.Rows.Count: scCount = srg.Columns.Count
rData(n) = srCount: cData(n) = scCount
If srCount > 1 Or scCount > 1 Then
Data(n) = srg.Value
Else
Data(n) = OneCell: Data(1, 1) = srg.Value
End If
drCount = drCount + srCount
If scCount > dcCount Then
dcCount = scCount
End If
Next srg
Dim Result() As String: ReDim Result(1 To drCount)
Dim r As Long, i As Long, j As Long
For n = 1 To aCount
For i = 1 To rData(n)
r = r + 1
For j = 1 To cData(n)
Result(r) = Result(r) & CStr(Data(n)(i, j)) & Delimiter
Next j
Result(r) = removeTrailingComma(Result(r), True)
Next i
Next n
Dim dFilePath As String
dFilePath = dFolderPath & "\" & dLeftBaseName _
& VBA.Format(VBA.Now, dTimeFormat) & dFileExtension
Dim TextFile As Long: TextFile = FreeFile
Dim TempString As String
Open dFilePath For Output As TextFile
Print #TextFile, Join(Result, vbLf)
Close TextFile
'wb.FollowHyperlink dFolderPath
End Sub
I am trying to loop through all named ranges in a workbook and save each object as a separate CSV file. I hacked the code below and it loops through all named ranges and it creates a bunch of CSV files, but it doesn't actuall export any data to any of those CSV files. What am I missing here?
Sub ExportAllNamedRanges()
Dim myCSVFileName As String
Dim myWB As Workbook
Dim rngToSave As Range
Dim fNum As Integer
Dim csvVal As String
Dim intCounter As Integer
Dim nmTemp As Name
Dim nm
Set myWB = ThisWorkbook
For Each nm In ThisWorkbook.Names
Debug.Print nm.Name
myCSVFileName = myWB.Path & "\" & nm.Name & ".csv"
csvVal = ""
fNum = FreeFile
Set rngToSave = Range(nm.Name)
Open myCSVFileName For Output As #fNum
For i = 1 To rngToSave.Rows.Count
For j = 1 To rngToSave.Columns.Count
csvVal = csvVal & Chr(34) & rngToSave(i, j).Value & Chr(34) & ","
Next
Print #fNum, Left(csvVal, Len(csvVal) - 2)
csvVal = ""
Next
Close #fileNumber
Next nm
End Sub
I figured it out. The code below works fine.
Sub ExportAllNamedRanges()
Dim myCSVFileName As String
Dim myWB As Workbook
Dim rngToSave As Range
Dim fNum As Integer
Dim csvVal As String
Dim intCounter As Integer
Dim nmTemp As Name
Dim nm
Set myWB = ThisWorkbook
For Each nm In ThisWorkbook.Names
Debug.Print nm.Name
Dim filename As String, lineText As String
Dim myrng As Range, i, j
filename = ThisWorkbook.Path & "\" & nm.Name & ".csv"
Open filename For Output As #1
Set myrng = Range(nm.Name)
For i = 1 To myrng.Rows.Count
For j = 1 To myrng.Columns.Count
lineText = IIf(j = 1, "", lineText & ",") & myrng.Cells(i, j)
Next j
Print #1, lineText
Next i
Close #1
Next nm
End Sub
Also, here is a nice and simple way to list all named ranges in a workbook.
Sub ListAllNamedRanges()
Dim nm As Name, n As Long, y As Range, z As Worksheet
Application.ScreenUpdating = False
Set z = ActiveSheet
n = 2
With z
.[A1:G65536].ClearContents
.[A1:C1] = [{"Name","Sheet Name","Range"}]
For Each nm In ActiveWorkbook.Names
.Cells(n, 1) = nm.Name
.Cells(n, 2) = Range(nm).Parent.Name
.Cells(n, 3) = nm.RefersToRange.Address(False, False)
n = n + 1
Next nm
End With
Set y = z.Range("C2:C" & z.[C65536].End(xlUp).Row)
y.TextToColumns Destination:=z.[C2], DataType:=xlDelimited, _
OtherChar:=":", FieldInfo:=Array(Array(1, 1), Array(2, 1))
[A:C].EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
I am able to read and write the current day's file to a text file for ease of input to sheet. But past day's reports with the same name differ in that they include the date in the name i.e. C:\Users\name\reports\report.html vs C:\Users\name\reports\archive\date\report.html I can't figure out how to tell it to go through dates selected. Additionally the report date shows as 06292019 not 06/29/2019.
I haven't tried much, as I don't really know where to start. Most of the questions I have browsed don't apply specifically enough.
Sub FindoldFile()
Dim fName As String
Dim fPath As String
Dim Rpt As String
Dim Source As String
Dim filePath As String
Dim Textfile As Integer
Dim Ifile As String
Dim CurRow As Long
fPath = "C:\Users\name\reports\"
Rpt = Dir(fPath & "reportname" & "date" & "_*")
'Would like to have "date" looped through date range input on sheet in cells
If Rpt = "" Then
MsgBox "No report found"
Exit Sub
End If
Source = fPath And Rpt
filePath = "C:\Data\report.txt"
Textfile = FreeFile
Open filePath For Output As Textfile 'First one as for output, second as for append?
Close Textfile
Kill "C:\Data\report.txt"
Ifile = "C:\Data\report.txt"
FileCopy Source, Ifile
Source = Ifile
'Here I would want to input multiple files from the date range selected
CurRow = 2
Open Source For Input As #1
Do While (Not EOF())
'do stuff
CurRow = CurRow + 1
Loop
Close #1
End Sub
I want to be able to put an start and end date values in two cells, then write all of them to .txt. Following that, input them to excel sheet.
Edit, after looking at the thread suggested by Siddharth, I have come up with this adaptation. Of which I will test out when I get back to work tomorrow and update after.
Sub FindOld()
Dim ws As Worksheet
Dim st As Range
Dim en As Range
Dim x As Integer
Dim stDate As Date
Dim enDate As Date
Dim d As Date
Dim LR As Long
Dim CurRow As Long
Dim wb As Workbook
Dim fPath As String
Dim fName As String
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Activate
fPath = "C:\Users\"
Dim LastRow As Long
With ActiveSheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow = 1
End If
LR = LastRow
End With
For x = 0 To LR - 2
Set st = Range("B2").Offset(x, 0)
Set en = Range("C2").Offset(x, 0)
stDate = DateSerial(Year(st), Month(st), Day(st))
enDate = DateSerial(Year(en), Month(en), Day(en))
Dim subPath As String
Dim Report As String
LR = LR + 1
For d = stDate To enDate
Debug.Print d
fName = Format(d, "mmddyyyy")
subPath = fPath & fName
Report = Dir(subPath & fName & "_*" & ".html")
Source = subPath And Rpt
filePath = "C:\Data\report.txt"
Textfile = FreeFile
If d = stDate Then
Open filePath For Output As Textfile
Close Textfile
Kill "C:\Data\report.txt"
Ifile = "C:\Data\report.txt"
FileCopy Source, Ifile
Source = Ifile
Else
Open filePath For Append As Textfile
Close Textfile
Ifile = "C:\Data\report.txt"
FileCopy Source, Ifile
Source = Ifile
End If
Next d
Next
CurRow = 2
Open Source For Input As #1
Do While (Not EOF())
'do stuff
CurRow = CurRow + 1
Loop
Close #1
Exit Sub
End Sub
I'm going to assume where you use the word date you want the text such as "06292019" and for that date to be worked out in the loop. In that case DoStuff should be something like:
if IsDate(sht.cells(CurRow, 1)) then
fDate = format(sht.cells(CurRow, 1), "mmddyyyy")
' Do stuff
end if
I am assuming you have a variable sht mapped to the relevant worksheet.
That loop will work if you have a range of dates in the rows. I you want to loop from one date to another, as you also mentioned, you'll want to create a loop on variable i set to 0, and then run the loop using (firstDate + i) as the loop date, and stop when (firstDate + i) is greater than lastDate.
Firstly, really sorry I am very new to vba and know that this will be a really basic question for a lot of people here but I am trying to learn.
I am trying to split an excel file down into seperate csv files based on the first block of code I have taken from this site.
I am also trying to run the second block of code somewhere within the first block to open the csv files and remove the "" it puts in there.
Both bits of code work seperately but I do not have the knowledge or skill to join them together. I have tried for over a day but bits like:
wb.SaveAs ThisWorkbook.Path & "\" & Prefix & "_" & WorkbookCounter
In the first block of code and trying to replace it with this:
xName = Application.GetSaveAsFilename("C:\Users\trd836c3\Desktop\PO creation files\Files for upload testing\" & "Purchase" & Format(Now(), "yyyymmddhhmmss"), "CSV File (*.csv), *.csv")
or any combination of it just do not work.
This is the code to split an excel file down from LuH on here, but it saves as an excel file, and I cannot work out how to change it to a csv with a YYYYMMDDHHMMSS filename.
Sub Test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim WorkbookCounter As Integer
Dim RowsInFile
Dim Prefix As String
Application.ScreenUpdating = False
'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 100 'how many rows (incl. header) in new files?
Prefix = "test"
For p = 1 To ThisSheet.UsedRange.Rows.Count Step RowsInFile
Set wb = Workbooks.Add
'Paste the chunk of rows for this file
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1),ThisSheet.Cells(p + RowsInFile - 1, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A1")
'Save the new workbook, and close it
wb.SaveAs ThisWorkbook.Path & "\" & Prefix & "_" & WorkbookCounter
wb.Close
'Increment file counter
WorkbookCounter = WorkbookCounter + 1
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
This code creates a csv file with the working file name, and removing speech marks, but I cannot get this to automatically break an excel file into individual csv files of 10 rows.
Sub Export()
'updateby Extendoffice 20160530
Dim xRg As Range
Dim xRow As Range
Dim xCell As Range
Dim xStr As String
Dim xTxt As String
Dim xName As Variant
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Please select data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xName = Application.GetSaveAsFilename("C:\Users\trd836c3\Desktop\PO creation files\Files for upload testing\" & "Purchase" & Format(Now(), "yyyymmddhhmmss"), "CSV File (*.csv), *.csv")
Open xName For Output As #1
For Each xRow In xRg.Rows
xStr = ""
For Each xCell In xRow.Cells
xStr = xStr & xCell.Value & Chr(9)
Next
While Right(xStr, 1) = Chr(9)
xStr = Left(xStr, Len(xStr) - 1)
Wend
Print #1, xStr
Next
Close #1
If Err = 0 Then MsgBox "The file has saved to: " & xName, vbInformation, "Kutools for Excel"
End Sub
If I understood your requirement correctly, below code will give you the result
Sub Test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim WorkbookCounter As Integer
Dim RowsInFile
Dim Prefix As String
Application.ScreenUpdating = False
'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 100 'how many rows (incl. header) in new files?
Prefix = "test"
For p = 1 To ThisSheet.UsedRange.Rows.Count Step RowsInFile
'Paste the chunk of rows for this file
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p +
RowsInFile - 1, NumOfColumns))
xName = ThisWorkbook.Path & "\" & Prefix & "_" & WorkbookCounter & ".csv"
Open xName For Output As #1
For Each xRow In RangeToCopy.Rows
xStr = ""
For Each xCell In xRow.Cells
xStr = xStr & xCell.Value & Chr(9)
Next
While Right(xStr, 1) = Chr(9)
xStr = Left(xStr, Len(xStr) - 1)
Wend
Print #1, xStr
Next
Close #1
'Increment file counter
WorkbookCounter = WorkbookCounter + 1
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
I have some csv files in one folder. They all contain 3 specific columns. The number of total columns and the order may vary.
I want to concatenate all 3 columns with an underscore and write them in a single column in the worksheet that is running the code.
Here is what I have so far:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Cells(i, 1) = Cells(i, Columns(0)) & "_" & Cells(i, Columns(1)) & "_" & Cells(i, Columns(2))
Next i
End Sub
As you can see, this does what I want, but only for the active sheet.
I actually want to loop through all csv files in the same folder as the active sheet and write the results in the first sheet, first column of the sheet running the code (which is not a csv itself obviously).
How can I do this?
thanks!
This is a code that will loop through a folder
Sub Button1_Click()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\WorkBookLoop\"
MyFile = Dir(MyDir & "*.xls") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
'do something here
MyFile = Dir()
Loop
End Sub
It depends how you are naming the worksheets you create from the CSV files. You could add all the worksheets to a collection and use a For...Each loop to execute the entire search and concatenate procedure within that loop. Note that you'd have to explicitly define the first sheet name as this won't change through successive loops:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Dim frontSheet as Worksheet
Dim wSheets as New Collection
Dim ws as Worksheet
Set frontSheet = Sheets("name of front sheet")
'Add all your CSV sheets to wSheets using the .Add() method.
For Each ws in wSheets
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = ws.Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
frontsheet.Cells(i, 1) = ws.Cells(i, Columns(0)) & "_" & ws.Cells(i, Columns(1)) & "_" & ws.Cells(i, Columns(2))
Next i
Next ws
End Sub
It's often slow and labourious to open CSV files in excel but VBA can read them as text files using a TextStream. Furthermore, file scripting objects let you work with files and directories directly. Something like this might be a better approach if you don't need to keep the files in a worksheet afterwards:
Sub SearchFoldersForCSV()
Dim fso As Object
Dim fld As Object
Dim file As Object
Dim ts As Object
Dim strPath As String
Dim lineNumber As Integer
Dim lineArray() As String
Dim cols() As Integer
Dim i As Integer
Dim frontSheet As Worksheet
Dim frontSheetRow As Integer
Dim concatString As String
Set frontSheet = Sheets("name of front sheet")
frontSheetRow = 1
strPath = "C:\where-im-searching\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
For Each file In fld.Files
If (Right(file.Name, 3) = "csv") Then
Debug.Print file.Name
Set ts = file.OpenAsTextStream()
lineNumber = 0
Do While Not ts.AtEndOfStream
lineNumber = lineNumber + 1
lineArray = Split(ts.ReadLine, ",")
If (lineNumber = 1) Then
'We are at the first line of the .CSV so
'find index in lineArray of columns of interest
'Add extra ElseIf as required
For i = LBound(lineArray) To UBound(lineArray)
If lineArray(i) = "Column 1" Then
cols(1) = i
ElseIf lineArray(i) = "Column 2" Then
cols(2) = i
ElseIf lineArray(i) = "Column 3" Then
cols(3) = i
End If
Next i
Else
'Read and store the column of interest from this
'row by reading the lineArray indices found above.
concatString = ""
For i = LBound(cols) To UBound(cols)
concatString = concatString & lineArray(i) & "_"
Next i
concatString = Left(concatString, Len(concatString) - 1)
frontSheet.Cells(frontSheetRow, 1).Value = concatString
frontSheetRow = frontSheetRow + 1
End If
Loop
ts.Close
End If
Next file
End Sub
You can find more information on FileSystemObject and TextStream here.