Solved: Word to Excel Copy

[jigar1276]

Hi,

I have created the following macro in a word file and it is working fine in Office 2007. I have added the Referances: Microsoft Excel 12.0 object library.


Sub Wellstone_Macro()
Dim fname As String
Dim PathToUse As String
Dim Target As Excel.Workbook
Dim Source As Document
Dim fd As FileDialog
Dim drange As Range
Dim strText As String, strText1 As String
Dim i As Long, j As Long
Dim oXL As Excel.Application
Dim tSheet As Excel.Worksheet
Dim ExcelWasNotRunning As Boolean
Dim MyInput As Long
'Input for which row needs to be captured
'MyInput = InputBox("Enter Row Number", _
' "Enter Row Number", 4)

'If Excel is running, get a handle on it; otherwise start a new instance of Excel
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")
If Err Then
ExcelWasNotRunning = True
Set oXL = New Excel.Application
End If
'On Error GoTo Err_Handler
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder containing the files."
If .Show = -1 Then
PathToUse = .SelectedItems(1) & "\"
Else
End If
End With
Set fd = Nothing
oXL.Visible = True

'Open the workbook
Set Target = oXL.Workbooks.Add
Set tSheet = Target.Sheets(1)
With tSheet
.Range("B1") = "File Name"
.Range("C1") = "Patient's Name"
.Range("D1") = "MED. REC. #"
.Range("E1") = "DICTATOR"
End With
If Len(PathToUse) = 0 Then
Exit Sub
End If
fname = Dir$(PathToUse & "*.rtf")
j = 1
While fname <> ""
Set Source = Documents.Open(PathToUse & fname)
With Source
j = j + 1
tSheet.Range("B" & j) = fname

'For i = 2 To .Paragraphs.Count
'If Not IsNumeric(Left(.Paragraphs(i).Range.Text, 1)) Or left(.Paragraphs(i).Range.Text, 1) = Then
'strText = .Paragraphs(4).Range.Text
'strText = WorksheetFunction.Clean(.Paragraphs(MyInput).Range.Text)
'tSheet.Range("B" & j) = strText

'End If
'Next i
For TT = 2 To .Paragraphs.Count
If LCase(Left(.Paragraphs(TT).Range.Text, 5)) = LCase("NAME:") Then
strText1 = WorksheetFunction.Clean(.Paragraphs(TT).Range.Text)
tSheet.Range("C" & j) = Mid(strText1, 8)
End If
Next TT
For TT = 2 To .Paragraphs.Count
If LCase(Left(.Paragraphs(TT).Range.Text, 17)) = LCase("MEDICAL RECORD #:") Then
strText1 = WorksheetFunction.Clean(.Paragraphs(TT).Range.Text)
tSheet.Range("D" & j) = Mid(strText1, 20)
End If
Next TT
For TT = 2 To .Paragraphs.Count
If LCase(Left(.Paragraphs(TT).Range.Text, 10)) = LCase("PHYSICIAN:") Then
strText1 = WorksheetFunction.Clean(.Paragraphs(TT).Range.Text)
tSheet.Range("E" & j) = Mid(strText1, 12)
End If
Next TT
End With
Source.Close wdDoNotSaveChanges
fname = Dir$()
Wend
tSheet.Cells.VerticalAlignment = xlTop
Set drange = Nothing
Set tSheet = Nothing
Set Target = Nothing
Set oXL = Nothing
Exit Sub
Err_Handler:
MsgBox Target & " caused a problem. " & Err.Description, vbCritical_
If ExcelWasNotRunning Then
oXL.Quit
End If
End Sub



I want to use the same macro with Office 2003. When I tried running the macro in Word 2003. I am getting the error in following line:

Set oXL = New Excel.Application


I tried adding the referances but didnt found any excel object library in the list.

Please help.

Thanks,
Jigar

[Dave]

Maybe create an application rather than using new? Here's some untested code which may help. Dave

Sub Wellstone_Macro()
Dim fname As String
Dim PathToUse As String
Dim Target As Excel.Workbook
Dim Source As Document
Dim fd As FileDialog
Dim j As Integer
Dim oXL As Excel.Application
Dim tSheet As Excel.Worksheet
Dim ExcelWasNotRunning As Boolean
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder containing the files."
If .Show = -1 Then
PathToUse = .SelectedItems(1) & "\"
Else
Set fd = Nothing
Exit Sub
End If
End With
Set fd = Nothing
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")
If Err Then
Err.Number = 0
ExcelWasNotRunning = True
Set oXL = New Excel.Application
End If
On Error GoTo Err_Handler
oXL.Visible = True

'Open the workbook
Set Target = oXL.Workbooks.Add
Set tSheet = Target.Sheets(1)
With tSheet
.Range("B1") = "File Name"
.Range("C1") = "Patient's Name"
.Range("D1") = "MED. REC. #"
.Range("E1") = "DICTATOR"
End With
fname = Dir$(PathToUse & "*.rtf")
j = 1
While fname <> ""
Set Source = Documents.Open(PathToUse & fname)
With Source
j = j + 1
tSheet.Range("B" & j) = fname
For TT = 2 To .Paragraphs.Count
If LCase(Left(.Paragraphs(TT).Range.Text, 5)) = LCase("NAME:") Then
tSheet.Range("C" & j) = Mid(WorksheetFunction.Clean(.Paragraphs(TT).Range.Text), 8)
End If
If LCase(Left(.Paragraphs(TT).Range.Text, 17)) = LCase("MEDICAL RECORD #:") Then
tSheet.Range("D" & j) = Mid(WorksheetFunction.Clean(.Paragraphs(TT).Range.Text), 20)
End If
If LCase(Left(.Paragraphs(TT).Range.Text, 10)) = LCase("PHYSICIAN:") Then
tSheet.Range("E" & j) = Mid(WorksheetFunction.Clean(.Paragraphs(TT).Range.Text), 12)
End If
Next TT
End With
Source.Close wdDoNotSaveChanges
fname = Dir$()
Wend
Set Source = Nothing
tSheet.Cells.VerticalAlignment = xlTop
Set tSheet = Nothing
Set Target = Nothing
Exit Sub
Err_Handler:
MsgBox Target & " caused a problem. " & Err.Description, vbCritical
On Error GoTo 0
If ExcelWasNotRunning Then
oXL.Quit
Set oXL = Nothing
End If
End Sub

[jigar1276]

Thanks a ton Dave. Your code is tested and Its working fine in both the versions for MS Office.