multiple text to excel + filename

[Sprayzen]

Hi guys,

the script attached imports multiple text files into a single worksheet (not multiple) which works fine. Textfile1 sends data to column A, Textfile2 sends data to column B and so forth (many rows of data)

Now the only problem I have is that I need to know which columns output is associated to which file since no column is labled with the filename (Textfile1,Textfile2 etc)

How do I go about putting the filename (Textfile1,Textfile2 etc) into Row1,2,etc assigned to match the column in which the data pulled from the textfiles?

Any help would be appreciated

[vba]Sub Text_file_convert()

Dim Filter As String, Title As String, msg As String
Dim i As Integer, FilterIndex As Integer
Dim FileName As Variant
Dim Path As String
Dim Drive As String
Dim OutputFile() As String

Filter = "Text Files (*.txt),*.txt,"
FilterIndex = 1

Title = "Choose the files you want to open"
Path = ThisWorkbook.Path
OutputFile = Split(Path, "\")
Drive = Left("C:\Temp\", 1)
ChDrive (Drive)
ChDir ("C:\Temp\")

With Application
FileName = .GetOpenFilename(Filter, FilterIndex, Title, , True)
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With

If Not IsArray(FileName) Then
MsgBox "No file was selected."
Exit Sub
End If

Workbooks.OpenText FileName:=FileName(LBound(FileName)), DataType:=xlDelimited, Tab:=True
With ActiveSheet
For i = LBound(FileName) + 1 To UBound(FileName)
With .QueryTables.Add(Connection:="TEXT;" & (FileName(i)), _
Destination:=ActiveSheet.Cells(1, i))
.Name = FileName(i)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next
End With
ChDir ("C:\Temp\")
ActiveWorkbook.SaveAs ("textarea.xls"), xlWorkbookNormal
MsgBox "Converted " & i - 1 & " files"
End Sub[/vba]

[Sprayzen]

Does anyone have any ideas?

I'm new to VBA and am lost with this problem

[hardlife]

Hi, hope this will help You Pavel

[vba]
Sub Text_file_convert()

Dim Filter As String, Title As String, msg As String
Dim i As Integer, FilterIndex As Integer
Dim FileName As Variant
Dim Path As String
Dim Drive As String
Dim OutputFile() As String

Filter = "Text Files (*.txt),*.txt,"
FilterIndex = 1

Title = "Choose the files you want to open"
Path = ThisWorkbook.Path
OutputFile = Split(Path, "\")
Drive = Left("C:\Temp\", 1)
ChDrive (Drive)
ChDir ("C:\Temp\")

With Application
FileName = .GetOpenFilename(Filter, FilterIndex, Title, , True)
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With

If Not IsArray(FileName) Then
MsgBox "No file was selected."
Exit Sub
End If

Workbooks.OpenText FileName:=FileName(LBound(FileName)), DataType:=xlDelimited, Tab:=True
Rows("1:1").Insert Shift:=xlDown
ActiveSheet.Cells(1, 1).Value = FileName

With ActiveSheet
For i = LBound(FileName) + 1 To UBound(FileName)
ActiveSheet.Cells(1, i).Value = FileName(i)
With .QueryTables.Add(Connection:="TEXT;" & (FileName(i)), _
Destination:=ActiveSheet.Cells(2, i))
.Name = FileName(i)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
'.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
'.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next
End With
ChDir ("C:\01\")
ActiveWorkbook.SaveAs ("textarea.xls"), xlWorkbookNormal
MsgBox "Converted " & i - 1 & " files"
End Sub
[/vba]

[Sprayzen]

Hi Pavel,

Thanks for your help

Ok that will place the 1st filename selected and its file path into A1 but not the others

What I am after is being able to place the file name (not path if possible) and also be able to carry filename into A1, filename into B1 etc in a loop

[hardlife]

HTH, example:

[vba]
OnlyFileName = Replace(PathAndFileName,Path,"")
[/vba]

Try this for A1
[vba]
ActiveSheet.Cells(1, 1).Value = Replace(FileName(1), "C:\01\", "")
[/vba]

Try this for B1 ..
[vba]
ActiveSheet.Cells(1, i).Value = Replace(FileName(i),"C:\01\","")
[/vba]

[Sprayzen]

Hi mate, is there a way to do the following with that string

- only show the filename without the extension
- setup a loop so it automatically logs it for any file?

Sorry if this sounds stupid but I'm new to VBA

[Sprayzen]

Its all good managed to work my way around it thanks again Pavel

[hardlife]

Hi Sprayzen,

me is happy to see it is working,

good luck and happy day

Pavel Humenuk