Open multiple text files and paste contents to single cell
 

Thanks to the contributions of others in this group I have a macro
which will open multiple text files (rtf to be precise) and copy them
into a single spreadsheet. However, the text files range in length and
when they are pasted into the sheet, they may range from 1 row to 50.

Since my ultimate goal is to use this file to import into an Oracle
database, I need to have the entire contents of each text file in a
single cell and then have the name of the file in the next column.

The macro I am using is the following:

Sub ImportText()
Dim fileRow As Integer
Dim pathname As String
Dim j As Integer, i As Integer, filenameLen As Integer


Application.DisplayAlerts = False
Application.ScreenUpdating = False


filetoOpen = Application.GetOpenFilename _
("Select Letter Files (*.rtf),*.txt", , , , True)


If IsEmpty(Range("A1")) Then
fileRow = 1
Else
fileRow = ActiveSheet.UsedRange.Rows( _
ActiveSheet.UsedRange.Rows.Count).Row + 1
End If


For i = 1 To UBound(filetoOpen, 1)
Workbooks.OpenText Filename:=filetoOpen(i), _
Origin:=xlWindows, StartRow:=1, _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, _
Space:=False, Other:=False


Debug.Print ActiveWorkbook.Name


Set newBook = ActiveWorkbook 'reference to textfile


ActiveSheet.UsedRange.Copy
With Workbooks("Import Letter
Templates.xls").Worksheets("Sheet1")
ActiveSheet.Paste Destination:=.Cells(fileRow, 1)
fileRow = .UsedRange.Rows( _
.UsedRange.Rows.Count).Row + 1
End With
Debug.Print fileRow
newBook.Close


Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Open multiple text files and paste contents to single cell
 

Hi there

I'm not sure if this is exactly what you're after as I am unfamiliar
with Oracle and still quite new with VBA but copy this code into a new
excel sheet (in a new module). Make sure the Microsoft Word 11.0*
Object Library is available in your references and run the macro!!

Option Explicit

Sub Copy_Text_File_To_Single_Cell()
'Just a quick check this
Dim WordOpen As Integer
WordOpen = MsgBox("Please ensure that Microsoft Word is open", 65,
"Word Open Check")
If WordOpen = 2 Then Exit Sub

Dim WDApp As Word.Application
Dim WDDoc As Word.Document
' Reference existing instance of Word 2003 (.11 derived from
word/office version number)
Set WDApp = GetObject(, "Word.Application.11")
WDApp.Documents.Open Filename:="E:\temp\File1.rtf"
'my 'File1.rtf' is around 1000 lines and is a 3 columb tab delimited
file, change path as necessary.
Set WDDoc = WDApp.ActiveDocument
Dim TextSelection As Variant
WDApp.Selection.WholeStory
TextSelection = WDApp.Selection

Dim PositionInText As Long
Dim NewText As String
For PositionInText = 1 To Len(TextSelection)
If Mid$(TextSelection, PositionInText, 1) < Chr$(0) Then
NewText = NewText & Mid$(TextSelection, PositionInText, 1)
End If

Next PositionInText

Cells(1, 1).Value = NewText

End Sub

I have tested this by copying the cell and pasting it into a new blank
word document afterwards and (with Formatting visable) you can see it
is similar to the previous file.

HTH

Rob