jazzyt2u
08-26-2008, 10:35 AM
I'm trying to cut down on repetitive coding. I have different sections of an excel spreadsheet that needs to clean up data and then copy it over to Word.
I have declared or named the word application and file earlier in the main Sub. When I go to the called sub and then paste data into the word document it leaves that sub and goes back to the main one.
Sub Demo()
Dim oWord As Object
Dim oDoc As Object
Dim rngT130 As Range
Dim rngT140 As Range
Dim rngT150 As Range
Dim rngT160 As Range
Dim rngT1000 As Range
Dim rngT1100 As Range
Dim rngT1200 As Range
Dim rngT1300 As Range
Dim rngT1400 As Range
Set oWord = CreateObject("Word.Application") 'Create an instance of word
Set oDoc = oWord.Documents.Open("H:\TashaA\Test2\AvonReportTemplate_AA.doc") 'Open word file
oWord.Visible = True
'I have coding here that copies other worksheet data over to Word
Sheets("DemoTable").Select
Range("F1").Select
oDoc.Bookmarks("DemoTable").Select
Columns("B:B").Select
On Error Resume Next
Selection.Find(What:="Region", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
If ActiveCell = "Region" Then
Paste2Word
End If
Columns("B:B").Select
On Error Resume Next
Selection.Find(What:="Country", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
If ActiveCell = "Country" Then
Paste2Word
End If
Columns("B:B").Select
On Error Resume Next
Selection.Find(What:="Location", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
If ActiveCell = "Location" Then
Paste2Word
End If
End Sub
Sub Paste2Word()
ActiveCell.Offset(2, 0).Select
Set rngT130 = Selection
Dim rngD130 As Range
Dim rngTD130 As Range
ActiveCell.Offset(12, 1).Select
Set rngD130 = Selection
Set rngTD130 = Range(rngT130, rngD130)
Do Until ActiveCell = "" Or ActiveCell.Offset(0, 1) = ""
ActiveCell.Offset(-12, 1).Select
Set rngT140 = Selection
Selection.End(xlDown).Select
Do Until rngTD130.Width + Range(rngT140, ActiveCell).Width > 540 Or ActiveCell.Offset(0, 1) = ""
ActiveCell.Offset(0, 1).Select
Loop
Set rngD140 = Selection
Set rngTD140 = Range(rngT140, rngD140)
Worksheets("DemoTable").Range(rngT130, rngD130).CopyPicture xlScreen, xlBitmap
oWord.Selection.PasteAndFormat Type:=wdFormatOriginalFormatting 'AS SOON AS IT GETS HERE IT GOES BACK TO THE Sub DEMO STATEMENT
Worksheets("DemoTable").Range(rngT140, rngD140).CopyPicture xlScreen, xlBitmap
oWord.Selection.PasteAndFormat Type:=wdFormatOriginalFormatting
oWord.Selection.TypeParagraph
Loop
End Sub
Please help. I don't there's more code that I'm showing in the Sub Paste2Word and I don't want to have to repeat it for each section.
I have declared or named the word application and file earlier in the main Sub. When I go to the called sub and then paste data into the word document it leaves that sub and goes back to the main one.
Sub Demo()
Dim oWord As Object
Dim oDoc As Object
Dim rngT130 As Range
Dim rngT140 As Range
Dim rngT150 As Range
Dim rngT160 As Range
Dim rngT1000 As Range
Dim rngT1100 As Range
Dim rngT1200 As Range
Dim rngT1300 As Range
Dim rngT1400 As Range
Set oWord = CreateObject("Word.Application") 'Create an instance of word
Set oDoc = oWord.Documents.Open("H:\TashaA\Test2\AvonReportTemplate_AA.doc") 'Open word file
oWord.Visible = True
'I have coding here that copies other worksheet data over to Word
Sheets("DemoTable").Select
Range("F1").Select
oDoc.Bookmarks("DemoTable").Select
Columns("B:B").Select
On Error Resume Next
Selection.Find(What:="Region", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
If ActiveCell = "Region" Then
Paste2Word
End If
Columns("B:B").Select
On Error Resume Next
Selection.Find(What:="Country", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
If ActiveCell = "Country" Then
Paste2Word
End If
Columns("B:B").Select
On Error Resume Next
Selection.Find(What:="Location", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
If ActiveCell = "Location" Then
Paste2Word
End If
End Sub
Sub Paste2Word()
ActiveCell.Offset(2, 0).Select
Set rngT130 = Selection
Dim rngD130 As Range
Dim rngTD130 As Range
ActiveCell.Offset(12, 1).Select
Set rngD130 = Selection
Set rngTD130 = Range(rngT130, rngD130)
Do Until ActiveCell = "" Or ActiveCell.Offset(0, 1) = ""
ActiveCell.Offset(-12, 1).Select
Set rngT140 = Selection
Selection.End(xlDown).Select
Do Until rngTD130.Width + Range(rngT140, ActiveCell).Width > 540 Or ActiveCell.Offset(0, 1) = ""
ActiveCell.Offset(0, 1).Select
Loop
Set rngD140 = Selection
Set rngTD140 = Range(rngT140, rngD140)
Worksheets("DemoTable").Range(rngT130, rngD130).CopyPicture xlScreen, xlBitmap
oWord.Selection.PasteAndFormat Type:=wdFormatOriginalFormatting 'AS SOON AS IT GETS HERE IT GOES BACK TO THE Sub DEMO STATEMENT
Worksheets("DemoTable").Range(rngT140, rngD140).CopyPicture xlScreen, xlBitmap
oWord.Selection.PasteAndFormat Type:=wdFormatOriginalFormatting
oWord.Selection.TypeParagraph
Loop
End Sub
Please help. I don't there's more code that I'm showing in the Sub Paste2Word and I don't want to have to repeat it for each section.