Solved: Create a new word doc for every worksheet?

[thedark123]

How do I go around doing a macro or a loop to create a new word document for every worksheet I have in a workbook

Lets say in a workbook I got 10 worksheet and if I run the macro or something I will have 10 word document.

Thanks

[mdmackillop]

Sub MakeDocs()
'This code requires a referece to the Word object model
Dim sh As Worksheet, Appword As New Word.Application
Set Appword = CreateObject("Word.Application")
Appword.Visible = True
For Each sh In Sheets
Appword.Documents.Add
Next
Set Appword = Nothing
End Sub

[thedark123]

mdmackillop one more question, how about making every new word doc to have the same name as the worksheet? And after creating all these new word doc they will be move over to a newly created folder

I got the code to create a new folder but how do I place all these newly created word doc to the correct folders?

Thanks for your help..

[thedark123]

Here is the code I have done:

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

[thedark123]

See this part:


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


I used your code but seems to be something wrong wif it.

[mdmackillop]

see below

[thedark123]

mdmackillop how do I do a preformat to the cells i copied over from excel and I wan to paste to word.

Here is the data i copied from excel:

http://i6.photobucket.com/albums/y226/thedark123/test1234.gif


And should appear in this format in word:

http://i6.photobucket.com/albums/y226/thedark123/screenshot3.gif

[mdmackillop]

You have already asked this question in another thread, and if I feel that I can contribute, would do so there.

[thedark123]

How do I create respective folder to store all the newly created word document?

"filess" in this case are the name of the excel file



Dim newfol As String
newfol = filess



Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
Dim MyFol As String
MyFol = ActiveWorkbook.Path
ChDir (MyFol)
MkDir (newfol)
MyFol = ActiveWorkbook.Path & "\" & filess & "\"
On Error Resume Next

[mdmackillop]

MyFol = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 4) & "\"

[thedark123]

Dim newfol As String
newfol = filess



Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
Dim MyFol As String
MyFol = ActiveWorkbook.Path
ChDir (MyFol)
MkDir (newfol)

MyFol = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 4) & "\"

On Error Resume Next


Is it like that? No new folder seems to be created...

here is my full code

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



' 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..."


Dim newfol As String
newfol = filess



Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
Dim totalcolumn As Integer
Dim MyFol As String
MyFol = ActiveWorkbook.Path

ChDir (MyFol)
MkDir (newfol)
' MyFol = ActiveWorkbook.Path & "\" & filess & "\"
MyFol = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 4) & "\"
On Error Resume Next





'Dim oTbl As Table
'Set oTbl = wdDoc.Tables.Add(Selection.Range, 11, 2)
'This code requires a referece to the Word object model

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

'Save as sheet name and close
wdDoc.SaveAs Filename:=MyFol & ws.Name & ".doc"

Next ws
'wdDoc.Close

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

[mdmackillop]

Sorry,
I missed the new folder. Here's my revised code

Sub MakeDocs()
'This code requires a referece to the Word object model
Dim sh As Worksheet, Appword As New Word.Application
Dim MyFol As String
Set Appword = CreateObject("Word.Application")
'Create a save path
MyFol = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 4) & "\"
MkDir MyFol
For Each sh In Sheets
'Create documents
Appword.Documents.Add
'Save as sheet name
Appword.ActiveDocument.SaveAs Filename:=MyFol & sh.Name & ".doc"
'Close document
Appword.ActiveDocument.Close
Next
Set Appword = Nothing
End Sub

[lucas]

Hi Malcolm,
I had to add:
sh.UsedRange.Copy
Appword.ActiveDocument.Range.Paste
Application.CutCopyMode = False
after:

Appword.Documents.Add


to get this to work...probably a better way....but?!
Works great though.

[thedark123]

Ok Solved thanks guys : mdmackillop and lucas =)