PDA

View Full Version : Macro to import entire text file into single cell



raghuram.sta
10-03-2012, 03:14 AM
Hi

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

I have some Text Files in a Directory
Eg: C:\Records\

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

I want to import Each Text File into One Single Cell

Like
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

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
10-03-2012, 07:11 AM
This is an example. The example imports only a single file from a specific directory. The entire contents are placed in cell B9:

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


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
10-03-2012, 07:26 AM
Thanks for the reply

Got some sort of solution after a long wait

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

Kenneth Hobs
10-03-2012, 07:33 AM
If you did not want to do subfolders of subfolders and just wanted the first txt file:
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.aspx?scid=kb;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

raghuram.sta
10-03-2012, 08:09 AM
Thanks Hobs

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