D
Dustin
Sub Macro()
'>>>>>>>>>>This Section Opens up the document<<<<<<<<<<<<<'
'#########################################################'
Dim wdApp As Word.Application, wdDoc As Word.Document
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open("Doc.doc")
wdApp.Visible = True
wdApp.Activate
'#########################################################'
'>>>>>>>>>>This Section Finds the Table<<<<<<<<<<<<<'
'#########################################################'
wdApp.Selection.Find.ClearFormatting
With wdApp.Selection.Find
.Text = "what i'm searching for"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wdApp.Selection.Find.Execute
wdApp.Selection.MoveUp Unit:=wdLine, Count:=1
wdApp.Selection.MoveDown Unit:=wdLine, Count:=172,
Extend:=wdExtend
wdApp.Selection.MoveUp Unit:=wdLine, Count:=2, Extend:=wdExtend
wdApp.Selection.Copy
wdApp.Documents.Close
wdApp.Visible = False
'#########################################################'
'>>>>>>>>>>This Selection Starts Excel<<<<<<<<<<<<<'
'#########################################################'
Dim exApp As Excel.Application
On Error Resume Next
Set exApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then 'Excel isn't already running
Set exApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
'#########################################################'
'>>>>>>>>>>This Selection Creates a new Sheet<<<<<<<<<<<<<'
'#########################################################'
Dim wSht As Worksheet
Dim shtName As String
shtName = ("WordStuff")
For Each wSht In Worksheets
If wSht.Name = shtName Then
MsgBox "Sheet already exists...Make necessary " & _
"corrections and try again."
Exit Sub
End If
Next wSht
Sheets.Add.Name = shtName
'#########################################################'
'>>>>>>>>>>This Selection Pastes the table from Word<<<<<<<<<<<<<'
'#########################################################'
exApp.ActiveSheet.Paste
exApp.ActiveCell.Activate
exApp.Columns("B").Select
'#########################################################'
End Sub
Thanks
'>>>>>>>>>>This Section Opens up the document<<<<<<<<<<<<<'
'#########################################################'
Dim wdApp As Word.Application, wdDoc As Word.Document
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open("Doc.doc")
wdApp.Visible = True
wdApp.Activate
'#########################################################'
'>>>>>>>>>>This Section Finds the Table<<<<<<<<<<<<<'
'#########################################################'
wdApp.Selection.Find.ClearFormatting
With wdApp.Selection.Find
.Text = "what i'm searching for"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wdApp.Selection.Find.Execute
wdApp.Selection.MoveUp Unit:=wdLine, Count:=1
wdApp.Selection.MoveDown Unit:=wdLine, Count:=172,
Extend:=wdExtend
wdApp.Selection.MoveUp Unit:=wdLine, Count:=2, Extend:=wdExtend
wdApp.Selection.Copy
wdApp.Documents.Close
wdApp.Visible = False
'#########################################################'
'>>>>>>>>>>This Selection Starts Excel<<<<<<<<<<<<<'
'#########################################################'
Dim exApp As Excel.Application
On Error Resume Next
Set exApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then 'Excel isn't already running
Set exApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
'#########################################################'
'>>>>>>>>>>This Selection Creates a new Sheet<<<<<<<<<<<<<'
'#########################################################'
Dim wSht As Worksheet
Dim shtName As String
shtName = ("WordStuff")
For Each wSht In Worksheets
If wSht.Name = shtName Then
MsgBox "Sheet already exists...Make necessary " & _
"corrections and try again."
Exit Sub
End If
Next wSht
Sheets.Add.Name = shtName
'#########################################################'
'>>>>>>>>>>This Selection Pastes the table from Word<<<<<<<<<<<<<'
'#########################################################'
exApp.ActiveSheet.Paste
exApp.ActiveCell.Activate
exApp.Columns("B").Select
'#########################################################'
End Sub
array?From this point how would I store the strings in the column B to an
Thanks