Here is the code I have done:

[VBA]Private Sub CommandButton1_Click()

Dim x
Dim lCount As Long
Dim lMax As Integer
Dim lMax1() As Integer
Dim lCount1() As Integer
Dim title() As String
Dim WS_Count As Integer
Dim i As Integer
Dim LastCol() As Integer



' Prompt the user for the folder to list.
x = InputBox("What folder do you want to list?" & Chr$(13) & Chr$(13) _
& "For example: C:\My Documents")

If x = "" Or x = " " Then
Response = MsgBox("Please Enter a Directory Location" _
& Chr$(13) & Chr$(13) & _
"To enter directory location, click No." & Chr$(13) & _
"To Exit, click Yes.", vbYesNo)
If Response = "6" Then
End If
Else

' Search Drive
ChDrive "C"
ChDir x

On Error Resume Next

' Place .xls files into Worksheet and tabulate data
outrow = 2
filess = Dir("*.xls")

While Not filess = ""
Workbooks.Open Filename:=filess, UpdateLinks:=False


Dim newfol As String
newfol = filess
ChDir "C:\Documents and Settings\Administrator\Desktop"
On Error Resume Next
MkDir (newfol)

' requires a reference to the Word Object library:
' in the VBE select Tools, References and check the Microsoft Word X.X object library
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."


Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
Dim totalcolumn As Integer

' Appword.Visible = True
'For Each ws In Sheets
' wdApp.Documents.Add
'Next
' Set wdApp = wdDoc


For Each ws In ActiveWorkbook.Worksheets
Application.StatusBar = "Copying data from " & ws.Name & "..."
totalcolumn = WorksheetFunction.Max(ws.Range("3:3")) + 3

For i = 3 To totalcolumn
If Not ws.Cells(3, i).Value = "" Then
ws.Range(ws.Cells(3, i), ws.Cells(9, i)).Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
Application.CutCopyMode = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter

' insert page break after all Worksheets except the last one
If Not i = totalcolumn Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
End If
Next i
Next ws

Set ws = Nothing
Application.StatusBar = "Cleaning up..."

' apply normal view
With wdApp.ActiveWindow
If .View.SplitSpecial = wdPaneNone Then
.ActivePane.View.Type = wdNormalView
Else
.View.Type = wdNormalView
End If
End With
Set wdDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
Application.StatusBar = False

filess = Dir()
Wend
End If
End Sub
[/VBA]