Copy from multiple excel workbooks to one word file

[Haikal]

i want to

1. select a folder which contains the excel files
2. in sheet1 in each file, copy A1:F50
3. go to Master word file
4. Paste as image
5. size the image to certain width

 

[tweedle]

Here's a starter routine for you

Dim path$, fName$
Dim wb As Workbook, r As Range
Dim wdApp As Object, wdDoc As Object
Sub Main()


Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Add
'Set wdApp = New Word.Application
'Set wdDoc = wdApp.Documents.Add


wdApp.Visible = True


path$ = fGetFolder
ChDir path$


fName$ = Dir("*.xlsx")


Do While fName$ <> ""
    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
        wdApp.Activate
        With wdApp.Selection
            '.TypeText Text:=wb.Name
            '.TypeParagraph
            .Paste
            .TypeParagraph
        End With
    End If
NextWB:
    On Error GoTo 0
    wb.Close SaveChanges:=False
    fName$ = Dir()
DoEvents
Loop


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


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

 

[Haikal]

That was brilliant!
but one thing i need to complete the task properly, the files are not copied in order.

for example: if the file names are 1,2,3,4,5,etc., they are copied in the word file as 3,2,4,5,1.

any help in it?

 

[tweedle]

Yeh, that's Dir() being of a random nature.

Here's a revised that will go in order. Also lists the files, in their order, at the end.

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

 

[Haikal]

This is so great, thanks a lot