Transfer word data to Excel throughword vba

[raj_092001]

Hi Forum,

I need help where some information needs to be transferred from word to excel. I got help from macropad, Paul Edstein, i am very much thankful to him. With his support i got this code below.

I want this to be simplified. This code works when it is closed. I want this to work when workbook is open and where and the information passes from word to excel and this should go from word vba code only (Specific for accuracy reasons). I tried multiple ways, but getting lot of errors when changing the code i am getting confused.

This information needs to be transferred to excel sheet.

With ActiveDocument
StrNum = .Bookmarks("claim_number").Range.Text
StrTxt = .Bookmarks("statement_of").Range.Text
A = (Len(.Range.Text) - Len(Replace(.Range.Text, "INAUDIBLE-A", ""))) / Len("INAUDIBLE-A")
L = (Len(.Range.Text) - Len(Replace(.Range.Text, "INAUDIBLE-L", ""))) / Len("INAUDIBLE-L")
p = .ComputeStatistics(wdStatisticPages)
End With

Thanks in advance.

The entire code is below:

Private Sub CommandButton1_Click()
Dim StrTxt As String, StrNum As String, A As Long, L As Long, p As Long, StrWkBk As String


Dim xlApp As Object, xlWkBk As Object, xlWkSht As Object, dRow As Long


Dim bStrt As Boolean, bOpen As Boolean, bSht As Boolean


StrWkBk = "C:\Users" & Environ("Username") & "\Documents\Workbook Name.xls"
Const StrWkSht As String = "Sheet1"
' Get the document data
With ActiveDocument
StrNum = .Bookmarks("claim_number").Range.Text
StrTxt = .Bookmarks("statement_of").Range.Text
A = (Len(.Range.Text) - Len(Replace(.Range.Text, "INAUDIBLE-A", ""))) / Len("INAUDIBLE-A")
L = (Len(.Range.Text) - Len(Replace(.Range.Text, "INAUDIBLE-L", ""))) / Len("INAUDIBLE-L")
p = .ComputeStatistics(wdStatisticPages)
End With
' Does the Excel file exist?
If Dir(StrWkBk) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBk, vbExclamation
Exit Sub
End If
' Does another user have the file open?
If IsFileLocked(StrWkBk) = True Then
' Report and exit if true
MsgBox "The Excel workbook is in use by:" & vbCr & GetFileOwner(StrWkBk) & _
vbCr & vbCr & "Please try again later.", vbExclamation, "File in use"
Exit Sub
End If
bStrt = False ' Flag to record if we start Excel, so we can close it later.
bOpen = False ' Flag to record if we open the workbook, so we can close it later.
bSht = False ' Flag to record if our worksheet exists.
' Is Excel is already running?
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
' Start Excel if it isn't running
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
' Record that we've started Excel.
bStrt = True
End If
On Error GoTo 0
With xlApp
' Hide our Excel session if we started it
If bStrt = True Then .Visible = False
' Check if the workbook is open.
For Each xlWkBk In .Workbooks
If xlWkBk.FullName = StrWkBk Then ' The current user has it open
Set xlWkBk = xlWkBk
bOpen = True
Exit For
End If
Next
' If not open by the current user.
If bOpen = False Then
' The file is available, so open it.
Set xlWkBk = .Workbooks.Open(FileName:=StrWkBk)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBk, vbExclamation
GoTo ErrExit
End If
End If
' Does our worksheet exist?
With xlWkBk
For i = 1 To .Sheets.Count
If .Sheets(i).Name = StrWkSht Then bSht = True
Exit For
Next
End With
If bSht = False Then
MsgBox "Cannot find the worksheet named: '" & StrWkSht & "' in:" & vbCr & StrWkBk, vbExclamation
GoTo ErrExit
End If
End With
' Everything is OK, so update our worksheet
Set xlWkSht = xlWkBk.Sheets(StrWkSht)
With xlWkSht
dRow = .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
.Range("A" & dRow).Value = StrNum
.Range("B" & dRow).Value = StrTxt
.Range("C" & dRow).Value = A
.Range("D" & dRow).Value = L
.Range("E" & dRow).Value = p
End With
ErrExit:
If Not xlWkBk Is Nothing Then If bOpen = False Then xlWkBk.Close Savechanges:=True
If Not xlApp Is Nothing Then If bStrt = True Then xlApp.Quit
Set xlWkSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub


Function IsFileLocked(strFileName As String) As Boolean
On Error Resume Next
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
IsFileLocked = Err.Number
Err.Clear
End Function


Function GetFileOwner(strFileName)
'Based on: http://www.vbsedit.com/scripts/security/ownership/scr_1386.asp
Dim objWMIService As Object, objFileSecuritySettings As Object, objSD As Object
Set objWMIService = GetObject("winmgmts:")
Set objFileSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting='" & strFileName & "'")
If objFileSecuritySettings.GetSecurityDescriptor(objSD) = 0 Then
GetFileOwner = objSD.Owner.Name
Else
GetFileOwner = "Unknown"
End If
End Function



Thanks in advance.

 

[Macropod]

Cross-posted at: http://www.vbaexpress.com/forum/sho...ader-Bookmark-into-Excel-VBA-Userform-textbox
Please read Mr Excel's policy on Cross-Posting in rule 13: http://www.mrexcel.com/forum/board-announcements/99490-forum-rules.html