G'day there Bob,

I am trying it from Excel not Word, but I cannot get past the copying of
sheets.

Can you post the full code as you have it in Word?



Certainly, thanks for having a look for me. Here 'tis...



Public Sub XLProcessor()


Dim obj_ACTIVEFOLDER As String

' Set files array to nothing so we don't end up with false data
ReDim str_INPUTFILEARRAY(0)

' Use folderpicker to obtain path to folder for processing
' If no folder (dialogue cancelled) then exit sub
obj_ACTIVEFOLDER = foldername
If obj_ACTIVEFOLDER = "" Then: GoTo bye

' Having got our folder location, begin to process files therein
str_INPUTFILEARRAY = getInputFiles(obj_ACTIVEFOLDER)
' First make sure that there's at least 1 spreadsheet in there
On Error Resume Next
If UBound(str_INPUTFILEARRAY) = 0 Then
MsgBox ("No XL files found in folder")
GoTo bye
End If

' Early binding code
Dim obj_xlAPP As Excel.Application
Dim obj_xlTGTWORKBOOK As Excel.Workbook
Dim obj_xlSRCWORKBOOK As Excel.Workbook


Set obj_xlAPP = CreateObject("Excel.Application")
Set obj_xlTGTWORKBOOK = obj_xlAPP.Workbooks.Add

obj_xlAPP.Application.Visible = True


obj_xlTGTWORKBOOK.Worksheets(1).Delete
obj_xlTGTWORKBOOK.Worksheets(1).Delete
obj_xlTGTWORKBOOK.Worksheets(1).Delete


obj_xlAPP.EnableEvents = True
obj_xlAPP.DisplayAlerts = False


For int_X = 0 To UBound(str_INPUTFILEARRAY)
Set obj_xlSRCWORKBOOK = GetObject(str_INPUTFILEARRAY(int_X))
obj_xlSRCWORKBOOK.Sheets(1).Copy Destination:
=obj_xlTGTWORKBOOK.Sheets.Add(after:=
(obj_xlTGTWORKBOOK.Worksheets.Count))

Next

Do Until obj_xlTGTWORKBOOK.Worksheets.Count = UBound
(str_INPUTFILEARRAY)
obj_xlTGTWORKBOOK.Worksheets.Add after:
=obj_xlTGTWORKBOOK.Worksheets(obj_xlTGTWORKBOOK.Wo rksheets.Count)
Loop



For int_X = 0 To UBound(str_INPUTFILEARRAY)
Set obj_xlSRCWORKBOOK = GetObject(str_INPUTFILEARRAY(int_X))
obj_xlSRCWORKBOOK.Sheets(1).UsedRange.Copy
obj_xlTGTWORKBOOK.Sheets(int_X + 1).Paste Destination:=Sheets
(int_X + 1).Range("A1")

Next


Debug.Print "Yes"


bye:
On Error GoTo 0

obj_xlAPP.EnableEvents = True
obj_xlAPP.DisplayAlerts = True

Set obj_xlAPP = Nothing
Set obj_xlTGTWORKBOOK = Nothing
Set obj_xlSRCWORKBOOK = Nothing


End Sub

Public Function foldername()

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.UserName & "\Desktop"
.Title = "Please select the folder containing current files"

.Show

If .SelectedItems.Count = 0 Then
foldername = ""
Else
foldername = .SelectedItems(1)
End If
End With

End Function

Public Function getInputFiles(path) As Variant
str_ERRORSTRING = ""
Dim int_Z As Integer
Dim int_X As Integer
With Application.fileSearch
.NewSearch
.Filename = "*.xls"
.LookIn = path
If .Execute < 0 Then
ReDim str_INPUTFILEARRAY(.FoundFiles.Count - 1)
For int_X = 0 To .FoundFiles.Count - 1
str_INPUTFILEARRAY(int_X) = .FoundFiles(int_X + 1)
Next int_X
End If
End With
With Application.fileSearch
.NewSearch
.Filename = "*.csv"
.LookIn = path
If .Execute < 0 Then
ReDim Preserve str_INPUTFILEARRAY(int_X + .FoundFiles.Count
- 1)
For int_Z = 0 To .FoundFiles.Count - 1
str_INPUTFILEARRAY(int_X + int_Z) = .FoundFiles(int_Z +
1)
Next
End If
End With
' If IsArray(str_INPUTFILEARRAY) Then
getInputFiles = str_INPUTFILEARRAY()
' Else
' str_ERRORSTRING = "No Excel Files in Folder"
' End If
End Function