Need macro to copy from Word into a VBA module

[lizzycole_photos]

So basically I have created a macro to break apart a large master file into smaller district files and email them to the appropriate contacts. To do this, I am using a generic macro, pasting that into Word, running a mail merge based on an excel list, and copying it back to a vba module. This creates 383 macros that i then run through another macro... (probably not the best way but it works for me)

Sub DCOR_D«District»()
'
'
ActiveSheet.Range("A:Y").AutoFilter Field:=3, Criteria1:="«District»"
Range("A:Y").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A2").Select
Application.CutCopyMode = False
Selection.AutoFilter
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2").Select
ChDir "G:\TTS\Reporting\District Class Offering Report\Weekly DCOR by District"

Dim fName As String, fPath As String
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
fPath = "G:\TTS\Reporting\District Class Offering Report\Weekly DCOR by District\"
fName = "T«Territory» R«Region» D«District» District Class Offering Report " & Format(Date, "YYYY MM DD")
<o> </o>
ActiveWorkbook.SaveAs fPath & fName
Application.DisplayAlerts = False

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "«DM_Email»"
.CC = "«DOC_Email»"
.Subject = "District «District» Class Offering Report for Weekending " & Format(Date, "YYYY MM DD")
.Body = Range("'DCOR Macro.xlsm'!G1") & vbCrLf & vbCrLf & "Enclosed Attachment" & vbCrLf & fName
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
<o> </o>
ActiveWorkbook.Close
End Sub
​

I would like to give this to the team that asked for it and not have to mess with it again. In order to do that, I am trying to get the mail merge to launch through excel and then to copy and paste the result back into the module. I have figured out how to do everything up to the copy peice at which point I get an error.

Sub OpenWord()
Dim wdApp As Object
Dim wdDoc As Object
Set wdApp = CreateObject("Word.application")
Set wdDoc = wdApp.Documents.Open _
(Filename:="G:\TTS\Reporting\District Class Offering Schedule\DCOS Macro Module 4 Mail Merge Doc.docm")
wdApp.Visible = True

ActiveDocument.MailMerge.OpenDataSource Name:= _
"G:\TTS\Reporting\District Class Offering Schedule\DCOS Macro.xlsm", _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=G:\TTS\Reporting\District Class Offering Schedule\DCOS Macro.xlsm;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=35;Je" _
, SQLStatement:="SELECT * FROM `Sheet1$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess

Application.DisplayAlerts = False

With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With

Selection.WholeStory - this is where the Debug points me (error '483')
Selection.Copy

End Sub

​

Also, I'm not certain how to finish it out - paste into the module and so on.

Thanks for any help you can provide!!!

 

[lizzycole_photos]

I'm trying to get this formatted properly.

So basically I have created a macro to break apart a large master file into smaller district files and email them to the appropriate contacts. To do this, I am using a generic macro, pasting that into Word, running a mail merge based on an excel list, and copying it back to a vba module. This creates 383 macros that i then run through another macro... (probably not the best way but it works for me)

Sub DCOR_D"«District»"()

ActiveSheet.Range("A:Y").AutoFilter Field:=3, Criteria1:="«District»"
Range("A:Y").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A2").Select
Application.CutCopyMode = False
Selection.AutoFilter
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2").Select
ChDir "G:\TTS\Reporting\District Class Offering Report\Weekly DCOR by District"
 
Dim fName As String, fPath As String
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
fPath = "G:\TTS\Reporting\District Class Offering Report\Weekly DCOR by District\"
fName = "T«Territory» R«Region» D«District» District Class Offering Report " & Format(Date, "YYYY MM DD")
<o:p></o:p>
ActiveWorkbook.SaveAs fPath & fName
Application.DisplayAlerts = False
 
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "«DM_Email»"
.CC = "«DOC_Email»"
.Subject = "District «District» Class Offering Report for Weekending " & Format(Date, "YYYY MM DD")
.Body = Range("'DCOR Macro.xlsm'!G1") & vbCrLf & vbCrLf & "Enclosed Attachment" & vbCrLf & fName
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
<o:p></o:p>
ActiveWorkbook.Close
End Sub

I would like to give this to the team that asked for it and not have to mess with it again. In order to do that, I am trying to get the mail merge to launch through excel and then to copy and paste the result back into the module. I have figured out how to do everything up to the copy peice at which point I get an error.

Sub OpenWord()
Dim wdApp As Object
Dim wdDoc As Object
Set wdApp = CreateObject("Word.application")
Set wdDoc = wdApp.Documents.Open _
(Filename:="G:\TTS\Reporting\District Class Offering Schedule\DCOS Macro Module 4 Mail Merge Doc.docm")
wdApp.Visible = True
 
ActiveDocument.MailMerge.OpenDataSource Name:= _
"G:\TTS\Reporting\District Class Offering Schedule\DCOS Macro.xlsm", _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=G:\TTS\Reporting\District Class Offering Schedule\DCOS Macro.xlsm;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=35;Je" _
, SQLStatement:="SELECT * FROM `Sheet1$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
 
Selection.WholeStory - this is where the Debug points me (error '483')
Selection.Copy
 
End Sub

​

Also, I'm not certain how to finish it out - paste into the module and so on.

Thanks for any help you can provide!!!