Need file I receive daily to create an excel file

[pfhmoney]

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?

 

[texasalynn]

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
                Else
                    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
            .NewSearch
            .LookIn = sDir
            .FileType = msoFileTypeWordDocuments
            .Execute
         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, _
                End:=.Paragraphs(p).Range.End)
            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
    Range("A:A").Clear
                Next lngFilecounter
    End With
    
    Worksheets("Start").Activate
    MsgBox "Done"
    ActiveWorkbook.Saved = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
errorhandler:
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
Range("A1:A200").Select
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

HTH