{quote}{login=levchaky}{date=01.06.2010 04:36}{thema=импорт из **.DOC файлов}{post}Добрый день.  
как можна из вордовского документа(документов), вытянуть даные( желательно неоткрывая его)  
в файл Excel{/post}{/quote}  
Вот код от уважаемого ZVI:  
 
' ZVI:2009-09-02    
' Импорт строк в Excel из doc  
Sub ToExcelFromWord()  
   
 ' --> Менять только здесь  
 Const MyFile = "C:\Temp\Primer.doc"   ' <-- Путь, имя, тип файла RTF    
 Const Destination = "A1"    ' <-- Адрес первой ячейки импорта  
 ' <--  
   
 Dim wdApp As Object, wdDoc As Object, IsNewApp  As Boolean  
 Dim Txt$, i&, Arr, wdWSm, x  
   
 ' Открыть RTF  
 On Error Resume Next  
 Set wdApp = GetObject(, "Word.Application")  
 If Err <> 0 Then  
   Err.Clear  
   Set wdApp = CreateObject("Word.Application")  
   IsNewApp = True  
 Else  
   With wdApp  
     i = .Documents.Count  
     .ScreenUpdating = False  
     wdWS = .WindowState  
     If wdWS <> 0 Then .WindowState = 0  
   End With  
 End If  
 Set wdDoc = wdApp.Documents.Open(MyFile, , True)  
 If Err <> 0 Then MsgBox "Не найден файл: " & MyFile, vbExclamation: Err.Clear: GoTo exit_  
 On Error GoTo 0 'exit_  
   
 ' Скопировать из Word в масссив Arr  
 Txt = wdDoc.Content  
 Txt = Replace(wdDoc.Range.Text, Chr(12), "")  
 Arr = Split(Txt, vbCr)  
 ' Заморозить Excel  
 With Application  
   .EnableEvents = False  
   '.ScreenUpdating = False  
   .Calculation = xlCalculationManual  
 End With  
 ' Скопировать из масссива Arr - в Excel  
 With Range(Destination)  
   ' Очистить  
   Set x = Cells(Rows.Count, .Column).End(xlUp)  
   If x.Row >= .Row Then Range(.Offset(0), x).ClearContents  
   ' Скопировать  
   With .Resize(UBound(Arr), 1)  
     .NumberFormat = "@"  
     .Font.Name = "Courier New"  
     .Font.Size = 10  
     .Value = Application.Transpose(Arr)  
     .Columns.AutoFit  
   End With  
 End With  
   
exit_:  
 ' Поймать ошибку  
 If Err <> 0 Then MsgBox Err.Description  
 ' Закрыть RTF  
 wdDoc.Close 0  
 Set wdDoc = Nothing  
 ' Закрыть приложение Word или оживить его (если ранее был открыт)  
 With wdApp  
   If IsNewApp Then  
     .Quit  
   Else  
     If .Documents.Count < i Then .Documents.Add  
     .WindowState = wdWS  
     .ScreenUpdating = True  
   End If  
 End With  
 Set wdApp = Nothing  
 ' Отморозить Excel  
 With Application  
   .EnableEvents = True  
   .Calculation = xlCalculationAutomatic  
   '.ScreenUpdating = True  
 End With  
   
   
End Sub