Need file I receive daily to create an excel file


New Member
Aug 6, 2006
Each day from 3 different vendors i receive via email files which I would like to create into an excel file.

One is a .dat file, the other two are .htm files - the htm files default open in Word. the dat file goes into excel but does not recognize the tab deliminted.

Perhaps my terminology is not "right on" however what I need with the files are to be able to do vlookups on them, manipulate them once they are in excel format. Right now it takes WAY TOO much of my time to get rid of the additional page breaks, blank rows, etc. as well as no division of information column wise.

I know there has to be a way to convert it from word into a tab delimited format but I am unable to find the process to do so.

Any suggestions?

Some videos you may like

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.


Well-known Member
May 19, 2002
I have a macro that reads a word document and puts it into Excel. Plus does several other things - so maybe this will give you a start

Sub OpenAndReadWordDoc()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim tString As String, tRange As Word.Range
Dim p As Long, r As Long
Dim objFolder As Object
Dim sDir As String
Dim wbDest As Workbook, wbBook As Workbook
Dim wbAllBooks As Workbooks
Dim shtDest As Worksheet
Dim intResponse As Integer, dblSum As Double
Dim rngMyRng As Range, cell As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    intResponse = MsgBox("This macro will transfer data in all workbooks of the selected folder to Access table" & vbCrLf & "Close all open workbooks before running this macro", vbExclamation + vbOKCancel, "Summarize Files")
    If intResponse = vbOK Then
            On Error GoTo errorhandler
            '// Selects the Root PC Dir!
            Set objFolder = CreateObject("Shell.Application"). _
                    BrowseForFolder(0, "Please Select Folder", 0, 0)
            If Not objFolder Is Nothing Then
                '// Is it the Root Dir?...if so change
                If Len(objFolder.Items.Item.Path) > 3 Then
                    sDir = objFolder.Items.Item.Path & Application.PathSeparator
                    sDir = objFolder.Items.Item.Path
                End If
            End If
            Set objFolder = Nothing  'release object from memory
            If Len(sDir) = 0 Then Exit Sub
    With Application.FileSearch
            .LookIn = sDir
            .FileType = msoFileTypeWordDocuments
         If .FoundFiles.Count = 0 Then Exit Sub
            'Process each file in folder
    For lngFilecounter = 1 To .FoundFiles.Count
    Set wrdApp = CreateObject("Word.Application")
    Set wrdDoc = wrdApp.Documents.Open(.FoundFiles(lngFilecounter))
    Worksheets("Input Data").Activate
        With Range("A1")
            .Formula = "Word Document Contents:"
            .Font.Bold = True
            .Font.Size = 14
            .Offset(1, 0).Select
        End With
    r = 3 ' startrow for the copied text from the Word document
    ' example word operations
    With wrdDoc
        For p = 1 To .Paragraphs.Count
            Set tRange = .Range(Start:=.Paragraphs(p).Range.Start, _
            tString = tRange.Text
            tString = Left(tString, Len(tString) - 1)
            ' check if the text has content
            If tString <> "" Then
                ' fill into active worksheet
                ActiveSheet.Range("A" & r).Formula = tString
                r = r + 1
            End If
        Next p
        .Close ' close the document
    End With
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Call TrimChr
    Worksheets("Input Data").Activate
                Next lngFilecounter
    End With
    MsgBox "Done"
    ActiveWorkbook.Saved = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End Sub

Sub TrimChr()
'David McRitchie 2000-07-03 mod 2000-08-16 join.htm
Application.ScreenUpdating = False
Dim cell As Range
Range("A1:A200").Replace What:=Chr(30), Replacement:="-", LookAt:=xlPart
Range("A1:A200").Replace What:=Chr(13), Replacement:="", LookAt:=xlPart
Range("A1:A200").Replace What:=Chr(9), Replacement:="", LookAt:=xlPart
Range("A1:A200").Replace What:=Chr(11), Replacement:="", LookAt:=xlPart
Range("A1:A200").Replace What:=Chr(21), Replacement:="", LookAt:=xlPart
On Error Resume Next 'in case no text cells in selection
For Each cell In Intersect(Selection, _
Selection.SpecialCells(xlConstants, xlTextValues))
cell.Value = Application.Trim(cell.Value)
Next cell
On Error GoTo 0
'Application.ScreenUpdating = True
End Sub


Watch MrExcel Video

Forum statistics

Latest member

This Week's Hot Topics

  • Change military grades into rank
    Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
    Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
    Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...
  • Auto-Create a monthly Sign in sheet for preschool students
    The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class" School days are obviously Monday-Friday but...
  • VBA vlookup multiple results
    Hi folks, Hopefully someone out there can help. I have a list to vlookup which works (ish). the lookup only picks up the first instance of the...
  • Extract values for earliest/latest times
    I am trying to put together a formula to get the earliest start time, the latest end time from column A for each person in Column B-F without the...