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



From this point how would I store the strings in the column B to an
array?


Thanks

Hi Dustin,

whether you do this in Word or in Excel doesn't matter,
if you really need it.

In Word:
Loop through all cells in a column
Cut off the end of cell mark.
Add the remainder of the cell's text to a string.

Sub Test33()
Dim s As String
Dim oCll As Cell
For Each oCll In ActiveDocument.Tables(1).Columns(2).Cells
s = s & Left(oCll.Range.Text, Len(oCll.Range.Text) - 2)
Next
MsgBox s
End Sub

But then you have the cell delimiters lost!
You have to take care of a delimiter.

In Excel to could add up all cell values to a string.
But still, you'd need a delimiter.

HTH

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"



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



From this point how would I store the strings in the column B to an
array?


Thanks

Dustin,

You can treat the range of cells as an array:

Dim myArr As Range
Dim myCell As Range
Dim exApp As Object

Set myArr = exApp.Range("B:B").SpecialCells(xlCellTypeConstant s)

For Each myCell In myArr
'Do something with each value, like
MsgBox myCell.Value
Next myCell

HTH,
Bernie
MS Excel MVP


"Dustin" wrote in message
oups.com...
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



From this point how would I store the strings in the column B to an
array?


Thanks

On Mar 26, 10:32 am, "Bernie Deitrick" <deitbe @ consumer dot org
wrote:
Dustin,

You can treat the range of cells as an array:

Dim myArr As Range
Dim myCell As Range
Dim exApp As Object

Set myArr = exApp.Range("B:B").SpecialCells(xlCellTypeConstant s)

For Each myCell In myArr
'Do something with each value, like
MsgBox myCell.Value
Next myCell

HTH,
Bernie
MS Excel MVP

"Dustin" wrote in message

oups.com...

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

From this point how would I store the strings in the column B to an
array?

Thanks

Thanks for the quick response. I got the information in arrays
properly as needed.

Thank Yall Very Much