Copiar ranges do excel para Word (indicadores) RRS feed

  • Pergunta

  • Boa tarde,

    tenho uma planilha excel com nome definidos, referenciandos células e tabelas. Tenho um arquivo Word com indicadores onde tenho que copiar do excel o Range (células e tabelas) e colar nesses indicadores.

    Tenho um programa que achei na internet, porém não consigo fazer ele colar com a formatação do documento destino (Word) corretamente.

    Devo inserir os 2 arquivos aqui ou algum link para download dos mesmos ?

    Sub RefreshAllCells()
    ''Purpose: To refresh the current table in a Word document with new data from
    '' the corresponding range in an Excel document.
    ''The code uses bookmarks in the Word document and corresponding named ranges in
    '' Excel. The Excel data is brought in as pictures. This has the advantage that any
    '' formatting in the Excel document is retained, and the dimensions don't change
    '' significantly.
    '' Also, bookmarks are simpler to create and maintain because a picture is only a
    '' single character in a Word document.
    ''Requires: A table in the Excel file to line up the bookmarks and named ranges
    ''Created: 23 Oct 2008 by Denis Wright
        Dim objExcel As Object, _
            objWbk As Object, _
            objDoc As Document
        Dim sBookmark As String, _
            sWbkName As String
        Dim sRange As String, _
            sSheet As String
        Dim BMRange As Range
        Dim bmk As Bookmark
        Dim i As Integer, _
            j As Integer, _
            k As Integer, _
            bmkCount As Integer
        Dim vNames()
        Dim vBookmarks()
        Dim dlgOpen As FileDialog
        Dim bnExcel As Boolean
        On Error GoTo Err_Handle
        Set dlgOpen = Application.FileDialog( _
        bnExcel = False
        Do Until bnExcel = True
            With dlgOpen
                .AllowMultiSelect = True
                If .SelectedItems.Count > 0 Then
                    sWbkName = .SelectedItems(1)
                    MsgBox "Please select a workbook to use for processing"
                End If
            End With
            If InStr(1, sWbkName, ".xls") > 0 Then
                bnExcel = True
                MsgBox "The file must be a valid Excel file. Try again please..."
            End If
        Set objDoc = ActiveDocument
        'check to see that the Excel file is open. If not, open the file
        'also grab the wbk name to enable switching
        Set objExcel = GetObject(, "Excel.Application")
        For i = 1 To objExcel.Workbooks.Count
            If objExcel.Workbooks(i).Name = sWbkName Then
                Set objWbk = objExcel.Workbooks(i)
                Exit For
            End If
        If objWbk Is Nothing Then
            Set objWbk = objExcel.Workbooks.Open(sWbkName)
        End If
        'minimize the Excel window
        objExcel.WindowState = -4140 'minimized
        'switch to Excel, find range name that corresponds to the bookmark
        objExcel.Visible = False
        vNames = objWbk.Worksheets("auto").Range("Cells").Value
        'loop through the bookmarks
        bmkCount = ActiveDocument.Bookmarks.Count
        ReDim vBookmarks(bmkCount - 1)
        j = LBound(vBookmarks)
        For Each bmk In ActiveDocument.Bookmarks
            vBookmarks(j) = bmk.Name
            j = j + 1
        Next bmk
        For j = LBound(vBookmarks) To UBound(vBookmarks)
            'go to the bookmark
            Selection.GoTo What:=wdGoToBookmark, Name:=vBookmarks(j)
            Set BMRange = ActiveDocument.Bookmarks(vBookmarks(j)).Range
            For k = 1 To UBound(vNames)
                If vNames(k, 1) = vBookmarks(j) Then
                    sSheet = vNames(k, 2)
                    sRange = vNames(k, 3)
                    Exit For
                End If
            Next k
            'copy data from the range as a picture
            'return to Word and paste
            'Note: only required if the bookmark encloses a picture.
            'If the bmk held text, deleting the selection removes the bmk too.
            'Under those circumstances the code throws an error.
            'Clunky workaround: tell Word to ignore the error
            On Error Resume Next
            On Error GoTo 0
            'paste the picture, then move back one character so the new bookmark
            'encloses the pasted picture
            Selection.PasteAndFormat (wdFormatPlainText)
            Selection.Move Unit:=wdCharacterFormatting, Count:=-1
            'now reinstate the bookmark
            objDoc.Bookmarks.Add Name:=vBookmarks(j), Range:=Selection.Range
        Next j
        'clean up
        Set BMRange = Nothing
        Set objWbk = Nothing
        objExcel.Visible = True
        Set objExcel = Nothing
        Set objDoc = Nothing
        MsgBox "The document has been updated"
        If Err.Number = 429 Then 'excel not running; launch Excel
            Set objExcel = CreateObject("Excel.Application")
            Resume Next
        ElseIf Err.Number <> 0 Then
            MsgBox "Error " & Err.Number & ": " & Err.Description
            Resume Err_Exit
        End If
    End Sub

    • Editado ltsuda terça-feira, 6 de maio de 2014 16:48 inserido link dos arquivos
    terça-feira, 6 de maio de 2014 16:45