Macro to import entire text file into single cell

[raghuram.sta]

Hi

I want to run a macro to Import Entire Text File in Single Cell

I have some Text Files in a Directory
[VBA]Eg: C:\Records\[/VBA]

Each Sub Folder will have 1 Text File
[VBA]Eg: C:\Records\Folder1\Text File1.txt
C:\Records\Folder2\Text File2.txt
C:\Records\Folder3\Text File3.txt[/VBA]

I want to import Each Text File into One Single Cell

Like
[VBA]Row Column A Column B
1 Text File1 Text File1 Content
2 Text File2 Text File2 Content
3 Text File3 Text File3 Content
4
5
[/VBA]
Is it possible to this through VBA. I have posted this question in many forums but no where I got response. Please at-least tell me if it is impossible or no way to do this

Please, please help me....

Thanks a million in advance

[GarysStudent]

This is an example. The example imports only a single file from a specific directory. The entire contents are placed in cell B9:

[VBA]Sub JustOneFile()
Dim s As String, st As String
Dim CellToFill As Range
Set CellToFill = Range("B9")
st = ""
Open "C:\TestFolder\def.txt" For Input As #1
Do Until EOF(1)
Line Input #1, s
If st = "" Then
st = s
Else
st = st & vbCrLf & s
End If
Loop
Close #1
CellToFill = st
End Sub
[/VBA]

To adapt this to your needs, you would have to loop over the txt files in your directory and select the cells that you wanted the contents placed.

[raghuram.sta]

Thanks for the reply

Got some sort of solution after a long wait

[VBA]Dim iRow As Long 'start row to put output
Dim Pathf, Path1 As String 'pathfolder
Dim subf As Boolean 'incl subfolders true/false
Dim Fdate, Tdate As Date
Dim intC As Integer
Dim Folder As Folder
Dim f As file
Dim fs As New FileSystemObject

Sub Read_Text_Files()
Application.ScreenUpdating = False

iRow = 3
Path1 = "C:\Records\"
Pathf = fs.GetFolder(Path1)
subf = True
Call ListMyFiles(Pathf, subf)
End Sub

Sub ListMyFiles(mySourcePath, IncludeSubfolders)
Dim Sh As Worksheet
Dim FileName As String
Dim FileNum As Integer
Dim r As Long
Dim Data As String
Dim Txt As String

Set MyObject = New Scripting.FileSystemObject
Set mySource = MyObject.GetFolder(mySourcePath)
On Error Resume Next

For Each myfile In mySource.Files
If Right(myfile.Name, 6) = "_o.txt" Then
iCol = 2
Cells(iRow, iCol).Value = myfile.Name
iCol = iCol + 1

FileName = myfile
FileNum = FreeFile
Open FileName For Input As #FileNum
Do While Not EOF(FileNum)
Line Input #FileNum, Data
Txt = Txt & Join(Split(Data, vbTab), " ") & " "
Loop
Cells(iRow, iCol).Value = Trim(Txt)
Txt = ""
Close #FileNum
iRow = iRow + 1
End If
Next

If IncludeSubfolders Then
For Each mySubFolder In mySource.SubFolders
Call ListMyFiles(mySubFolder.Path, True)
Next
End If
End Sub[/VBA]

[Kenneth Hobs]

If you did not want to do subfolders of subfolders and just wanted the first txt file:
[vba]Sub Test_SubfoldersTextFileContent()
SubfoldersTextFileContet "C:\Records"
End Sub

Rem Needs Reference: Tools > References > MicroSoft Scripting Runtime, scrrun.dll
Rem Instructions: http://support.microsoft.com/default...b;en-us;186118
Sub SubfoldersTextFileContent(aFolder As String)
Dim fso As New FileSystemObject
Dim pFolder As Folder, f As String, sf As Folder
Dim r As Range
If Dir(aFolder, vbDirectory) = "" Then Exit Sub
Set r = Range("A" & Rows.Count).End(xlUp).Offset(1)
With fso
Set pFolder = .GetFolder(aFolder)
For Each sf In pFolder.SubFolders
f = sf.Path & "\" & Dir(sf.Path & "\*.txt")
If .FileExists(f) Then
r.Value2 = .GetBaseName(f)
r.Offset(, 1).Value2 = TXTStr(f)
Set r = r.Offset(1)
End If
Next sf
End With
End Sub

Function TXTStr(filePath As String) As String
Dim str As String, hFile As Integer

If Dir(filePath) = "" Then
TXTStr = "NA"
Exit Function
End If

hFile = FreeFile
Open filePath For Binary Access Read As #hFile
str = Input(LOF(hFile), hFile)
Close hFile

TXTStr = str
End Function
[/vba]

[raghuram.sta]

Thanks Hobs

Quite Interesting Function. Thanks for the time taken... Thank you