从多个Excel工作簿复制到一个word文件

Question

我想

1. 选择包含excel文件的文件夹
在每个文件的sheet1中
2. ，复制A1：F50
3. 转到主文字文件
4. 粘贴为图像
5. 将图像调整为一定宽度

Answer 1

我在另一个论坛找到了答案，你在这里。

Dim path$, fName$
    Dim wb As Workbook, r As Range
    Dim wdApp As Object, wdDoc As Object
    Dim FSO As Object
    Dim fldr As Object
    Dim f As Object
    Dim rpt As Object


    Sub Main()


        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set wdApp = CreateObject("Word.Application")
        Set wdDoc = wdApp.Documents.Add
        Set rpt = CreateObject("Scripting.Dictionary")


        'Control the environment
        'Turn off Calculations
        calcmode = Application.Calculation
        Application.Calculation = xlCalculationManual
        Application.EnableEvents = False
        wdApp.Visible = True


        'Start Work
        path$ = fGetFolder
        Set fldr = FSO.GetFolder(path$)


        Application.ScreenUpdating = False

        For Each f In fldr.Files
            fName$ = f.Name
            If InStr(1, fName$, ".xlsx", vbTextCompare) > 0 Then
                On Error Resume Next


                Set wb = Workbooks.Open(path$ & fName$, ReadOnly:=True, AddToMRU:=False)
                Set ws = wb.Sheets("Sheet1")
                If Err > 0 Then GoTo NextWB:


                If Not ws Is Nothing Then
                    Set r = ws.Range("A1:F50")
                    r.CopyPicture xlScreen, xlPicture

                    With wdApp.Selection
                        .Paste  'Paste Image
                        .TypeParagraph
                    End With
                    rpt.Add wb.Name, wb.Name
                End If
    NextWB:
                On Error GoTo 0
                wb.Close SaveChanges:=False
                DoEvents
            End If
        Next f


    'Output Report
        wdApp.Selection.TypeParagraph
        s = rpt.Keys
        For i = 0 To UBound(s) - 1
            wdApp.Selection.Style = "No Spacing"
            wdApp.Selection.TypeText Text:=s(i) & vbLf
        Next i

        wdApp.Selection.TypeParagraph
        wdApp.Selection.TypeText Text:="Done " & Now()


    'Wrap Up
        Application.Calculation = calcmode
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        wdApp.Visible = True


    End Sub
    Private Function fGetFolder() As String
        fGetFolder = ""
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = Application.DefaultFilePath & "\"
            .Title = "Please select a folder"
            .Show


            If .SelectedItems.Count = 0 Then
                MsgBox "Cancelled. No folder was selected."
                fGetFolder = "Cancelled"
            Else
                fGetFolder = .SelectedItems(1) & "\"
            End If
        End With
    End Function