Hi, and welcome to the forum.
I have used a couple of functions to strip out the various part of the file name.
First we need to get the sheet name
The function takes the filename as an argument and string out the characters between the underscore and the period.
Rich (BB code):
Private Function GetSheetName(ByVal FileName As String) As String
Dim startChar As Long
Dim endChar As Long
startChar = InStr(1, FileName, "_", vbTextCompare) + 1
endChar = InStr(1, FileName, ".", vbTextCompare)
GetSheetName = Mid(FileName, startChar, endChar - startChar)
End Function
We also need to determine the output column.
Again we pass the filename as an argument,
strip out the characters to the left of the underscore,
and use a Select Case statement to determine the out put column.
Rich (BB code):
Private Function OutputColumn(ByVal FileName As String) As Long
Dim ColumnName As String
ColumnName = UCase(Left(FileName, InStr(1, FileName, "_", vbTextCompare) - 1))
Select Case ColumnName
Case "DENSITY"
OutputColumn = 1
Case "LENGTH"
OutputColumn = 2
Case "CONCENTRATION"
OutputColumn = 3
Case Else
OutputColumn = 4
End Select
End Function
After we open the source file we need to determine the number of rows to copy.
I have assumed the data is in column A.
This time we pass the worksheet as an argument and get the range in column A to copy.
Rich (BB code):
Private Function GetSourceRange(ByVal ws As Worksheet) As String
Dim lr As Long
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
GetSourceRange = "A1:A" & lr
End Function
There is a procedure to insert headers in newly created worksheets.
Rich (BB code):
Private Sub InsertHeaders(ByVal SheetName As String)
With Sheets(SheetName)
.Range("A1").Value = "Density"
.Range("B1").Value = "Length"
.Range("C1").Value = "Concentration"
.Range("D1").Value = "Speed"
End With
End Sub
The Main() procedure loops through all the csv file in the folder
NB You will need to edit the folder path REMEMBER THE END BACKSLASH.
Rich (BB code):
Sub Main()
Dim sPath As String
Dim sFile As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim rw As Long 'output row
Dim col As Long 'output column
Dim SheetName As String
Dim copyRange As String
sPath = "C:\temp\MrExcel\" 'REMEMBER END BACKSLASH
sFile = Dir(sPath & "*.csv")
Do Until sFile = ""
'==============================================
'get sheet name,
'test if sheet name exists, if not create it
'==============================================
SheetName = GetSheetName(sFile)
On Error Resume Next
Set wsTarget = Sheets(SheetName)
If wsTarget Is Nothing Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = SheetName
Set wsTarget = Sheets(SheetName)
'insert headers
InsertHeaders SheetName
End If
On Error GoTo 0
'==================================
'get the output column
'=================================
col = OutputColumn(sFile)
'=================================
'open source file
'get the number of rows to copy
'===============================
Set wbSource = Workbooks.Open(sPath & sFile)
Set wsSource = wbSource.Worksheets(1)
copyRange = GetSourceRange(wsSource)
'==================================
'copy and paste
'==================================
wsSource.Range(copyRange).Copy Destination:=wsTarget.Cells(2, col)
'===========================
'close file and tidy up
'==========================
Set wsSource = Nothing
wbSource.Close SaveChanges:=False
Set wbSource = Nothing
Set wsTarget = Nothing
'get next file
sFile = Dir()
Loop
End Sub
Place all the code above into a standard module, i.e., Insert=>Module.
Test initially using a couple of files and press F8 to step through the code one line at a time. This will give you a better understanding of what the code does.
Hope this helps,
Bertie
