[Solved] VBA: Range of data from Excel into Word VBA

pkwu · Oct 15th 2003

Hi there, please help.

I am using Word VBA to import a range of data (may include chart) from Excel. In Word, I used Inlineshape object to act as a Excel object. Once the data is imported, user needs to be able to modify if they wish; however, the file is not linked to original file. I have problem importing the data into excel. The pastespecial method somehow does not work. Here are the code:

Sub Test7()

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
On Error GoTo Err_Test
Application.ScreenUpdating = False
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(FileName)
xlBook.Application.Visible = False
xlBook.Application.WindowState = xlMinimized

Dim InShape As InlineShape
Dim objXL As Object
Dim gXL As Excel.Worksheet

ActiveDocument.InlineShapes.AddOLEObject ClassType:="Excel.Sheet.8", LinkToFile _
:=False, DisplayAsIcon:=False
Set InShape = ActiveDocument.InlineShapes(1)
InShape.Activate
Set objXL = InShape.OLEFormat.Object
Set gXL = objXL.ActiveSheet

' Method 1 succeed only when in debug mode
xlBook.Application.Range("A30:P88").Copy Destination:=gXL.Range("A1")

' Method 2 Fails completely
xlBook.Application.Range("C30:P88").Copy
gXL.PasteSpecial xlPasteValues
xlApp.CutCopyMode = False
SendKeys "{esc}", True

Exit_Test:
xlBook.Close False
xlApp.CutCopyMode = False
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
Set InShape = Nothing
Set xlObj = Nothing
Application.ScreenUpdating = True
Exit Sub
Err_Test:
MsgBox Err.Description
GoTo Exit_Test

End Sub

I have method 1 and method 2, but none of them seems to work.

Thank you for your help.

XL-Dennis · Oct 16th 2003

Hi and welcome to the board

Below You find a solution that I regular use from XL to Word.

Hopefully You may find some part of it workable in Your case.

Code

Option Explicit


Sub Export_Word()
   Dim wbBok As Workbook
   Dim wsBlad As Worksheet
   Dim rnRapport As Range
   Dim wdApp As Word.Application
   Dim wdDoc As Word.Document
   Dim BMRange As Word.Range
   Dim oShape As Word.InlineShape
   
   Set wbBok = ThisWorkbook
   Set wsBlad = wbBok.Worksheets("Sheet1")


   With wsBlad
      Set rnRapport = .Range("Rapport")
   End With
   
   Application.ScreenUpdating = False
   rnRapport.Copy
   Set wdApp = CreateObject("Word.Application")
   Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\Test.doc")


   With ActiveDocument.InlineShapes(1)
      .Select
      .Delete
   End With


  Set BMRange = ActiveDocument.Bookmarks("Rapport").Range
  With BMRange
      .Select
      .PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
            Placement:=wdInLine, DisplayAsIcon:=False
   End With


  With wdApp.ActiveDocument
      .Save
      .Close
  End With


  wdApp.Quit
  Set wdDoc = Nothing
  Set wdApp = Nothing


 With Application
      .CutCopyMode = False
      .ScreenUpdating = True
 End With


MsgBox "The report succesfully transferred to the document", vbInformation
End Sub

Display More

Kind regards,
Dennis

Anonymous · Oct 16th 2003

As Dennis has done, I post below portions of some code I've been using to copy data from Excel and paste it (formatted) into Word. Perhaps this will provide some additional ideas for you.

Code

Sub MakeWordFile()
'   Creates Word document of Auction Items using Automation
    Dim WordApp As Object
    Dim LastRow As Integer, i As Integer, r As Integer, Records As Integer


    On Error Resume Next
    Application.ScreenUpdating = False


'   Start Word and create an object
    Set WordApp = CreateObject("Word.Application")
    With WordApp
        .Documents.Add
    End With
    
'   Determine the file name
    SaveAsName = ThisWorkbook.Path & "\" & "2003 Auction Catalog.doc"
   
'   Sort Worksheet into proper catalog order
    Sheets("Items").Select
    Cells.Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, _
        Key2:=Range("B2"), Order2:=xlAscending, _
        Key1:=Range("C2"), Order3:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("A2").Select
        
' Delete Empty rows from "Items" worksheet
    LastRow = Selection.SpecialCells(xlCellTypeLastCell).Rows.Row
    Application.StatusBar = "Deleting Empty Rows from " & LastRow & " Used Rows"
'   Cycle through all records in Items
    For r = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountA(Rows(r)) = 0 _
          Then Rows(r).Delete
    Next r
        
' Update Last Row value in case rows were deleted
    Sheets("Items").Range("Title").FormatConditions.Delete
    Records = ActiveSheet.UsedRange.Rows.Count
        
' Information from worksheet
    Set Data = Sheets("Items").Range("A1")
        
' Cycle through all records in Items
    
    For i = 2 To Records
' Update status bar progress message
        Application.StatusBar = "Processing Record " & i & " of " & Records


' Assign current data to variables
        Letter = Data.Offset(i - 1, 0).Value
        Number = Data.Offset(i - 1, 1).Value
        Title = Data.Offset(i - 1, 2).Value
        Descript = Data.Offset(i - 1, 3).Value
        FMV = Format(Data.Offset(i - 1, 4).Value, "#,000")
        FMText = Data.Offset(i - 1, 5).Value
        Donor = Data.Offset(i - 1, 6).Value
        
' Send commands to Word
        With WordApp
            With .Selection
                .TypeParagraph
                .Font.Name = "Times New Roman"
                .Font.Size = 12
                .Font.Bold = True
                .ParagraphFormat.Alignment = 0
                .TypeText Text:=Letter & Number & ". "
                .Font.Underline = True
                .Font.AllCaps = True
                .TypeText Text:=Title
                .Font.AllCaps = False
                .Font.Bold = False
                .Font.Underline = False
                .TypeParagraph
                .TypeText Text:=Descript
                .Font.Name = "Georgia"
                .Font.Bold = True
                .Font.Size = 10
                .TypeText Text:="  Fair market value " & Format(FMV, "$#,##0") _
                     & FMText & ". "
                .Font.Name = "Times New Roman"
                .Font.Bold = False
                .Font.Size = 12
                .Font.Italic = True
                .TypeText Text:=Donor
                .TypeParagraph
                .Font.Italic = False
            End With
        End With
    Next i
    
' Save the Word file and close it
    With WordApp
            .ActiveDocument.SaveAs FileName:=SaveAsName
            .ActiveWindow.Close
' Kill the object
            .Quit
    End With


    Set WordApp = Nothing


' Reset status bar
    Application.StatusBar = ""
    MsgBox "Auction Catalog.doc was created and saved in " & ThisWorkbook.Path
End Sub

Display More

[Solved] VBA: Range of data from Excel into Word VBA

Participate now!

Share

Users Viewing This Thread