+ Reply to Thread
Results 1 to 2 of 2

Open multiple text files and paste contents to single cell

  1. #1

    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
    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

    With Workbooks("Import Letter
    ActiveSheet.Paste Destination:=.Cells(fileRow, 1)
    fileRow = .UsedRange.Rows( _
    .UsedRange.Rows.Count).Row + 1
    End With
    Debug.Print fileRow

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

  2. #2

    Re: 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
    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.



+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)


Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1