J
jlp1782
I wrote the Macro in Excel, and I sometimes get this error, and I do
not understand why. Sometimes it works, and other times, it does not.
I cannot figure out what is going on. Any help is much appreciated!
Scroll down to see where error is!
What the macro does...
It goes to each section with Heading style 1 and highlights that
section to where the section breaks are, then copies that section and
pastes it in an Excel spreadsheet. Each section goes into a new
column. Once it is in the excel spreadsheet, I have it so the common
stuff is matched up.
Sub Word2Excel()
'
' Word2Excel Macro
' Macro recorded 4/9/2006 by Jessica Patla
'
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'-----------------------------------IMPORTANT------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
' In order for this Macro to work, make sure Excel processes are ended
(Ctrl+Alt+Del)
' Then open Try.xls enabling Macros. Then Select All and right click
doing a Delete
' to all sheets!
' Save the document. Keep Excel Open.
' Make sure there are no empty product fields, all must be filled out
' Run the Macro in Word, then run the other Macro in Excel
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'Counts how many Products are in document
ctTOC = Word.ActiveDocument.CountNumberedItems - 1
'------------------------------------------------------------------------------------------
'Used for Excel sheet
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlSh As Excel.Worksheet
Dim xlRng As Excel.Range
Dim cellDest As Integer
'-------------------------------------------------------------------
'Used for column selection
'-------------------------------------------------------------------
Dim rng As Excel.Range
cellDest = 1
'Replaces Page Breaks with stars -- this is needed to get to next
heading
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = "abcde"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'Goes to each heading an makes copies the heading to a normal style
Dim prodChange As Integer
prodChange = 1
Do While prodChange <= ctTOC
If prodChange = 1 Then
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToNext,
Count:=prodChange, Name:=""
Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.Style = ActiveDocument.Styles("Normal")
Selection.MoveRight Unit:=wdCharacter, Count:=8,
Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=2
Selection.InsertBreak (wdSectionBreakNextPage)
prodChange = prodChange + 1
ElseIf prodChange = ctTOC Then
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToNext
Selection.InsertBreak (wdSectionBreakNextPage)
'Selection.MoveDown Unit:=wdLine, Count:=1
prodChange = prodChange + 1
Else
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToNext
Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.MoveRight Unit:=wdCharacter, Count:=5
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.Style = ActiveDocument.Styles("Normal")
Selection.MoveRight Unit:=wdCharacter, Count:=8,
Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=2
Selection.InsertBreak (wdSectionBreakNextPage)
prodChange = prodChange + 1
End If
Loop
prodChange = 1
'------------------------------------------------------------------
'Removing abcde
'------------------------------------------------------------------
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "abcde"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'-------------------------------------------------------------------
'Pasting it into Excel
'-------------------------------------------------------------------
'Return to start of Document
Selection.HomeKey Unit:=wdStory
Do While prodChange < ctTOC
If prodChange = 1 Then
'Needed for loop
prodChange = prodChange + 1
'Goes to the heading
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToFirst
Selection.MoveDown Unit:=wdLine, Count:=1
'Five Selection extends hightlights the whole sect
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Copy
'Starts Excel
Set xlApp = New Excel.Application
'Opens the already created workbook "Blah" and goes to Sheet 1
'Display Alerts are False. This will make it so nothing will
interupt
'the open (ex. enable macros)
xlApp.DisplayAlerts = False
'Opens Document
Set xlWb = xlApp.Workbooks.Open("D:\My Documents\Try.xls")
'Display Alerts need to be set back to true!
xlApp.DisplayAlerts = True
Set xlSh = xlWb.Sheets("Sheet1")
Dim xlCell As Cell
Dim ws As Worksheet
Dim lr As Integer
'Activates the Worksheet
xlSh.Activate
Set rng = xlSh.Range("A1")
'Display Alerts are False. This will make it so nothing will
interupt the paste
xlApp.DisplayAlerts = False
**************************************************************************
THIS IS WHERE I GET THE ERROR, BUT ONLY SOME TIME
**************************************************************************
'Paste into column rng and row 1
ActiveSheet.Paste
Destination:=Worksheets("Sheet1").Range("A1:A50")
'Display Alerts need to be set back to true!
xlApp.DisplayAlerts = True
'Activates Word
Word.ActiveDocument.Activate
cellDest = cellDest + 1
Else
'Goes to the heading (but since there are section breaks, it
stops at bottom of section)
'So, a move down is needed to get to the next header
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToNext
Selection.MoveDown Unit:=wdLine, Count:=1
'Needed for loop
prodChange = prodChange + 1
'5 selection extends highlights the whole section
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Extend
'Copying Selection
Selection.Copy
'Activating Excel
xlSh.Activate
'Moves rng over one column
'Set rng = rng.Offset(0, 1)
'Display Alerts are False. This will make it so nothing will
interupt the paste
xlApp.DisplayAlerts = False
'Paste into column rng and row 1
With ActiveSheet
prodChange = prodChange - 1 'Needed for the paste
.Paste Destination:=Worksheets("Sheet1").Range(.Cells(1,
prodChange), .Cells(500, prodChange))
prodChange = prodChange + 1 'Needed to reset
End With
'Display Alerts need to be set back to true!
xlApp.DisplayAlerts = True
'Shows Excel
xlApp.Visible = True
'Activating word again
Word.ActiveDocument.Activate
End If
Loop
'Displays Excel
xlApp.Visible = True
End Sub
not understand why. Sometimes it works, and other times, it does not.
I cannot figure out what is going on. Any help is much appreciated!
Scroll down to see where error is!
What the macro does...
It goes to each section with Heading style 1 and highlights that
section to where the section breaks are, then copies that section and
pastes it in an Excel spreadsheet. Each section goes into a new
column. Once it is in the excel spreadsheet, I have it so the common
stuff is matched up.
Sub Word2Excel()
'
' Word2Excel Macro
' Macro recorded 4/9/2006 by Jessica Patla
'
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'-----------------------------------IMPORTANT------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
' In order for this Macro to work, make sure Excel processes are ended
(Ctrl+Alt+Del)
' Then open Try.xls enabling Macros. Then Select All and right click
doing a Delete
' to all sheets!
' Save the document. Keep Excel Open.
' Make sure there are no empty product fields, all must be filled out
' Run the Macro in Word, then run the other Macro in Excel
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'Counts how many Products are in document
ctTOC = Word.ActiveDocument.CountNumberedItems - 1
'------------------------------------------------------------------------------------------
'Used for Excel sheet
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlSh As Excel.Worksheet
Dim xlRng As Excel.Range
Dim cellDest As Integer
'-------------------------------------------------------------------
'Used for column selection
'-------------------------------------------------------------------
Dim rng As Excel.Range
cellDest = 1
'Replaces Page Breaks with stars -- this is needed to get to next
heading
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = "abcde"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'Goes to each heading an makes copies the heading to a normal style
Dim prodChange As Integer
prodChange = 1
Do While prodChange <= ctTOC
If prodChange = 1 Then
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToNext,
Count:=prodChange, Name:=""
Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.Style = ActiveDocument.Styles("Normal")
Selection.MoveRight Unit:=wdCharacter, Count:=8,
Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=2
Selection.InsertBreak (wdSectionBreakNextPage)
prodChange = prodChange + 1
ElseIf prodChange = ctTOC Then
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToNext
Selection.InsertBreak (wdSectionBreakNextPage)
'Selection.MoveDown Unit:=wdLine, Count:=1
prodChange = prodChange + 1
Else
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToNext
Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.MoveRight Unit:=wdCharacter, Count:=5
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.Style = ActiveDocument.Styles("Normal")
Selection.MoveRight Unit:=wdCharacter, Count:=8,
Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=2
Selection.InsertBreak (wdSectionBreakNextPage)
prodChange = prodChange + 1
End If
Loop
prodChange = 1
'------------------------------------------------------------------
'Removing abcde
'------------------------------------------------------------------
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "abcde"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'-------------------------------------------------------------------
'Pasting it into Excel
'-------------------------------------------------------------------
'Return to start of Document
Selection.HomeKey Unit:=wdStory
Do While prodChange < ctTOC
If prodChange = 1 Then
'Needed for loop
prodChange = prodChange + 1
'Goes to the heading
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToFirst
Selection.MoveDown Unit:=wdLine, Count:=1
'Five Selection extends hightlights the whole sect
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Copy
'Starts Excel
Set xlApp = New Excel.Application
'Opens the already created workbook "Blah" and goes to Sheet 1
'Display Alerts are False. This will make it so nothing will
interupt
'the open (ex. enable macros)
xlApp.DisplayAlerts = False
'Opens Document
Set xlWb = xlApp.Workbooks.Open("D:\My Documents\Try.xls")
'Display Alerts need to be set back to true!
xlApp.DisplayAlerts = True
Set xlSh = xlWb.Sheets("Sheet1")
Dim xlCell As Cell
Dim ws As Worksheet
Dim lr As Integer
'Activates the Worksheet
xlSh.Activate
Set rng = xlSh.Range("A1")
'Display Alerts are False. This will make it so nothing will
interupt the paste
xlApp.DisplayAlerts = False
**************************************************************************
THIS IS WHERE I GET THE ERROR, BUT ONLY SOME TIME
**************************************************************************
'Paste into column rng and row 1
ActiveSheet.Paste
Destination:=Worksheets("Sheet1").Range("A1:A50")
'Display Alerts need to be set back to true!
xlApp.DisplayAlerts = True
'Activates Word
Word.ActiveDocument.Activate
cellDest = cellDest + 1
Else
'Goes to the heading (but since there are section breaks, it
stops at bottom of section)
'So, a move down is needed to get to the next header
Selection.GoTo What:=wdGoToHeading, Which:=wdWordGoToNext
Selection.MoveDown Unit:=wdLine, Count:=1
'Needed for loop
prodChange = prodChange + 1
'5 selection extends highlights the whole section
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Extend
Selection.Extend
'Copying Selection
Selection.Copy
'Activating Excel
xlSh.Activate
'Moves rng over one column
'Set rng = rng.Offset(0, 1)
'Display Alerts are False. This will make it so nothing will
interupt the paste
xlApp.DisplayAlerts = False
'Paste into column rng and row 1
With ActiveSheet
prodChange = prodChange - 1 'Needed for the paste
.Paste Destination:=Worksheets("Sheet1").Range(.Cells(1,
prodChange), .Cells(500, prodChange))
prodChange = prodChange + 1 'Needed to reset
End With
'Display Alerts need to be set back to true!
xlApp.DisplayAlerts = True
'Shows Excel
xlApp.Visible = True
'Activating word again
Word.ActiveDocument.Activate
End If
Loop
'Displays Excel
xlApp.Visible = True
End Sub