Hello everyone
I've written a macro which is designed to run through a selected range of cells, open a word document, paste data from the selected rows into a table, and then save the document as a different file (so it creates one document for each row).
You need these files to run it:
https://dl.dropbox.com/u/420883/New%20folder/Book1.xlsm
https://dl.dropbox.com/u/420883/New%20folder/Tracker%20Template.docx
However it has several problems:
[*]I keep getting an error 4198 when runnning it on Excel/Word 2007.
[*]It also sometimes prompts me to save changes to the Normal.dot template, and because it's opening and closing Word this causes major problems as it causes Excel to freeze, Word to freeze etc.
[*]I would like to filter on certain columns in the Excel file, select those rows, and have it only work on those rows, but I'm unsure how to do this.
[*]The ErrorHandler is to handle where sometimes the RecordInfo(1) may have a / or a : in it, which means the file name will be invalid, so the user is prompted to rename it. Could these values be removed automatically?
Please can you take a look at let me know how you think it could be improved?
Option Explicit
Sub AutoFillWordTables()
Dim C As Range
Dim FileFilter As String
Dim Rng As Range
Dim WordFile As String
Dim wdApp As Object
Dim wdDoc As Object
Dim wdTbl As Object
Dim Wks As Worksheet
Dim fldr As Variant
Dim proceed As Variant
Dim strPath As String
Dim retVal As Variant
On Error GoTo ErrHandler:
Dim RecordInfo(0 To 12)
Set Rng = Nothing
Set Rng = Selection
proceed = MsgBox("This will create a tracker for the " & Rng.Rows.Count & " currently selected rows. Click OK to continue", vbOKCancel, "Create Tracker")
If proceed = vbOK Then
MsgBox ("Select Tracker Template")
FileFilter = "All Files(*.*),*.*"
WordFile = Excel.Application.GetOpenFilename(FileFilter)
If WordFile = "False" Then
MsgBox ("No file selected, exiting")
Exit Sub
End If
MsgBox ("Select destination folder")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fldr = .SelectedItems(1)
End With
If fldr = "False" Then
MsgBox ("No folder selected, exiting")
Exit Sub
End If
For Each C In Rng
If InStr(1, Cells(C.Row, 11), "CLOSED") > 0 Then
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(WordFile)
RecordInfo(0) = Cells(C.Row, 1)
RecordInfo(1) = Cells(C.Row, 2)
RecordInfo(2) = Cells(C.Row, 3)
RecordInfo(3) = Cells(C.Row, 4)
RecordInfo(4) = Cells(C.Row, 5) '
wdDoc.Tables(1).Cell(2, 2).Range.Text = RecordInfo(0)
wdDoc.Tables(1).Cell(3, 2).Range.Text = RecordInfo(1)
wdDoc.Tables(1).Cell(4, 2).Range.Text = RecordInfo(2)
wdDoc.Tables(1).Cell(5, 2).Range.Text = RecordInfo(3)
wdDoc.Tables(1).Cell(6, 2).Range.Text = RecordInfo(4)
strPath = fldr & "" & RecordInfo(1) & " - " & RecordInfo(2) & " v0.1"
wdApp.ActiveDocument.SaveAs strPath, FileFormat:=16
'nnnext:
wdApp.ActiveDocument.Close>
wdApp.Application.Quit
End If
Next C
MsgBox ("Complete")
retVal = Shell("explorer.exe " & fldr, vbNormalFocus)
Else
Exit Sub
End If
Set wdApp = Nothing
Set wdDoc = Nothing
Set wdTbl = Nothing
ErrHandler:
If Err.Number = 5152 Then
MsgBox ("File name (i.e. the title) contains invalid character. Please change this so that the tracker can be saved")
With wdApp.FileDialog(msoFileDialogSaveAs)
.InitialFileName = strPath
.Show
.Execute
End With
Resume Next
Else
MsgBox ("Error: " & Err.Number)
End If
End Sub
I've written a macro which is designed to run through a selected range of cells, open a word document, paste data from the selected rows into a table, and then save the document as a different file (so it creates one document for each row).
You need these files to run it:
https://dl.dropbox.com/u/420883/New%20folder/Book1.xlsm
https://dl.dropbox.com/u/420883/New%20folder/Tracker%20Template.docx
However it has several problems:
[*]I keep getting an error 4198 when runnning it on Excel/Word 2007.
[*]It also sometimes prompts me to save changes to the Normal.dot template, and because it's opening and closing Word this causes major problems as it causes Excel to freeze, Word to freeze etc.
[*]I would like to filter on certain columns in the Excel file, select those rows, and have it only work on those rows, but I'm unsure how to do this.
[*]The ErrorHandler is to handle where sometimes the RecordInfo(1) may have a / or a : in it, which means the file name will be invalid, so the user is prompted to rename it. Could these values be removed automatically?
Please can you take a look at let me know how you think it could be improved?
Option Explicit
Sub AutoFillWordTables()
Dim C As Range
Dim FileFilter As String
Dim Rng As Range
Dim WordFile As String
Dim wdApp As Object
Dim wdDoc As Object
Dim wdTbl As Object
Dim Wks As Worksheet
Dim fldr As Variant
Dim proceed As Variant
Dim strPath As String
Dim retVal As Variant
On Error GoTo ErrHandler:
Dim RecordInfo(0 To 12)
Set Rng = Nothing
Set Rng = Selection
proceed = MsgBox("This will create a tracker for the " & Rng.Rows.Count & " currently selected rows. Click OK to continue", vbOKCancel, "Create Tracker")
If proceed = vbOK Then
MsgBox ("Select Tracker Template")
FileFilter = "All Files(*.*),*.*"
WordFile = Excel.Application.GetOpenFilename(FileFilter)
If WordFile = "False" Then
MsgBox ("No file selected, exiting")
Exit Sub
End If
MsgBox ("Select destination folder")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fldr = .SelectedItems(1)
End With
If fldr = "False" Then
MsgBox ("No folder selected, exiting")
Exit Sub
End If
For Each C In Rng
If InStr(1, Cells(C.Row, 11), "CLOSED") > 0 Then
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(WordFile)
RecordInfo(0) = Cells(C.Row, 1)
RecordInfo(1) = Cells(C.Row, 2)
RecordInfo(2) = Cells(C.Row, 3)
RecordInfo(3) = Cells(C.Row, 4)
RecordInfo(4) = Cells(C.Row, 5) '
wdDoc.Tables(1).Cell(2, 2).Range.Text = RecordInfo(0)
wdDoc.Tables(1).Cell(3, 2).Range.Text = RecordInfo(1)
wdDoc.Tables(1).Cell(4, 2).Range.Text = RecordInfo(2)
wdDoc.Tables(1).Cell(5, 2).Range.Text = RecordInfo(3)
wdDoc.Tables(1).Cell(6, 2).Range.Text = RecordInfo(4)
strPath = fldr & "" & RecordInfo(1) & " - " & RecordInfo(2) & " v0.1"
wdApp.ActiveDocument.SaveAs strPath, FileFormat:=16
'nnnext:
wdApp.ActiveDocument.Close>
wdApp.Application.Quit
End If
Next C
MsgBox ("Complete")
retVal = Shell("explorer.exe " & fldr, vbNormalFocus)
Else
Exit Sub
End If
Set wdApp = Nothing
Set wdDoc = Nothing
Set wdTbl = Nothing
ErrHandler:
If Err.Number = 5152 Then
MsgBox ("File name (i.e. the title) contains invalid character. Please change this so that the tracker can be saved")
With wdApp.FileDialog(msoFileDialogSaveAs)
.InitialFileName = strPath
.Show
.Execute
End With
Resume Next
Else
MsgBox ("Error: " & Err.Number)
End If
End Sub
