even for non newbies this isn't exacly straightforward
Try following:
please be careful while testing as I've experienced some
crashes due to:
not closing the objects window before deleting the object...
Sub RetrieveEmbeddedXLS()
Dim wdDOC As Object
Dim wdOIL As Object
Dim wdEMB As Object
Dim xlEMB As OLEObject
Dim xlWKS As Worksheet
Dim xlwkb As Workbook
Dim r As Long, b As Long
Dim sDoc As String
sDoc = Application.GetOpenFilename("Word files, (*.doc)")
If sDoc = vbNullString Then Exit Sub
Set xlWKS = ThisWorkbook.Worksheets(1)
xlWKS.OLEObjects.Delete
r = 1
xlWKS.Activate
'First get them from word onto the activesheet...
Set wdDOC = GetObject(sDoc)
For Each wdOIL In wdDOC.inlineshapes
Set wdEMB = wdOIL.OLEFormat
If LCase$(wdEMB.progID) Like "excel.sheet*" Then
wdEMB.Parent.Range.Copy
xlWKS.Cells(r, 1).Activate
xlWKS.PasteSpecial _
Format:="Microsoft Excel Worksheet Object", _
Link:=False, DisplayAsIcon:=True
r = r + 6
End If
Next
Set wdEMB = Nothing
Set wdOIL = Nothing
wdDOC.Close (0)
Set wdDOC = Nothing
For Each xlEMB In ActiveSheet.OLEObjects
b = b + 1
xlEMB.Object.Windows(1).Visible = True
ActiveWorkbook.SaveAs "retrieved from " & _
Replace(Dir(sDoc), ".doc", "", compare:=vbTextCompare) & b & ".xls"
xlEMB.Object.Windows(1).Visible = False
Next
xlWKS.OLEObjects.Delete
End Sub
HTH.. and good luck
--
keepITcool
|
www.XLsupport.com | keepITcool chello nl | amsterdam
Raven1 wrote :
