#1
|
|||
|
|||
Extract data form one Excel file to another
Hi,
I don't post here often and I work primarily with Word and Word VBA, but occasionally need a bit of help with Excel. In this case, it might be a lot of help. I have an existing process where I have a Word document form with content controls where the content control titles serve as column headings in a separate Excel file. Several Word forms are completed each day and the at the end of the day, I run a procedure in an Excel file where the the data in each completed Word form is extracted and saved as a new record in the Excel file. All works well. I would like to expand my process where I have an Excel spreadsheet embedded within the Word document and data entered into the embedded Excel spreadsheet is also extracted. Can anyone offer any tips or code on how this might be achieved? Thank you. |
#2
|
||||
|
||||
Greg
I did a google search and found some relevant code by Andy Pope which works in Word to read or write to its own embedded spreadsheet. Code:
Sub WriteToSS() 'Sourced from... 'https://social.msdn.microsoft.com/Forums/en-US/c4969934-0a4a-4e2c-bb56-cf05f756dc82/can-you-use-vba-to-access-a-spread-sheet-embedded-in-a-word-doc?forum=isvvba ' added a couple of lines to read cell values and save any changes Dim objSS As InlineShape With ActiveDocument.InlineShapes(1) .OLEFormat.DoVerb wdOLEVerbHide With .OLEFormat.Object.Application With .Workbooks(1).Worksheets(1) Debug.Print .Cells(1, 1).Value, .Range("B1").Value 'reading cells .Cells(1, 1).Value = "Hello" 'writing to a cell .Range("B1").Value = "Big Boy" 'writing to another cell End With .Workbooks(1).Save 'if you wanted to save the changed cell values .Quit End With End With End Sub Getting the right InlineShape might be a bit tricky and relying on its numerical position in the document is problematic so I would probably use Format Object to set its Alt Text to a unique value so the code could iterate through all the InlineShapes to find the one which has that Alt Text value. An example of looping through a docs Shapes (same for InlineShapes) is shown in this thread.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
Andrew,
Thanks for the reply. I'm sorry I didn't get back here last night to update this thread. I had cobbled together something that seemed to work and was so excited about it, I forgot :-( In my main routing which opens the Word document containing the embedded Excel file, I run this code: Code:
'Get the embedded data arrLabs = fcnGetEmbeddedLabData(oDoc) 'Set the target worksheet Set oSheet = Worksheets("Labs") 'Get target range (last row) lngLastRow = oSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1 'Write the extracted values oSheet.Cells(lngLastRow, "A").Resize(1, UBound(arrLabs) + 1).Value = arrLabs '... 'More code to close the Word doc and process next doc. Function fcnGetEmbeddedLabData(oDocPassed As Object) As String() 'Returns values in last column of embedded worksheet to a array. Dim oILS As InlineShape Dim oWS As Worksheet Dim oWB As Workbook Dim lngRow As Long, lngCol As Long Dim lngRows As Long Dim arrData() As String ReDim arrData(287) For Each oILS In oDocPassed.InlineShapes If oILS.Type = wdInlineShapeEmbeddedOLEObject Then If oILS.OLEFormat.progID = "Excel.Sheet.12" Then oILS.OLEFormat.Edit Set oWB = Workbooks(2) Set oWS = oWB.Sheets(1) lngCol = oWS.Cells(2, oWS.Columns.Count).End(xlToLeft).Column lngRows = oWS.Cells(Rows.Count, "A").End(xlUp).Row arrData(0) = oDocPassed.SelectContentControlsByTitle(strCCUnique).Item(1).Range.Text For lngRow = 1 To lngRows Select Case oWS.Cells(lngRow, lngCol).Text Case Is = "#DIV/0!", "#NUM!", "#VALUE!" Case Else arrData(lngRow) = oWS.Cells(lngRow, lngCol).Text End Select Next lngRow End If End If Next oILS fcnGetEmbeddedLabData = arrData() lbl_Exit: Set oWB = Nothing: Set oWS = Nothing Exit Function End Function This seems to work nicely. Will look at your example in more detail. Thanks again. |
#4
|
||||
|
||||
Looks like you already have it sorted. I will make a few minor suggestions to tidy it up a bit
1. Why redim the array if you already know how many slots Code:
Dim arrData(287) As String Code:
Set oWB = oILS.OLEFormat.Object 'does this work Code:
For lngRow = 1 To lngRows arrData(lngRow) = WorksheetFunction.IfError(Cells(lngRow, lngCol), "") Next lngRow
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#5
|
|||
|
|||
Andrew, thanks for the additional comments and help. It is always nice to have an expert on staff
Good point about fixed value for array dimension. Setting the worksheet to the OLE.Object also works. Had troubles eliminating the Select Case complexity though. Here is the new code: Code:
Function fcnGetEmbeddedLabData(oDocPassed As Object) As String() Dim oILS As InlineShape Dim oWS As Worksheet Dim oWB As Workbook Dim lngRow As Long, lngCol As Long Dim lngRows As Long Dim arrData() As String For Each oILS In oDocPassed.InlineShapes If oILS.Type = wdInlineShapeEmbeddedOLEObject Then If oILS.OLEFormat.progID = "Excel.Sheet.12" Then oILS.OLEFormat.Edit 'Set oWB = Workbooks(2) Set oWB = oILS.OLEFormat.Object Set oWS = oWB.Sheets(1) lngCol = oWS.Cells(2, oWS.Columns.Count).End(xlToLeft).Column lngRows = oWS.Cells(Rows.Count, "A").End(xlUp).Row ReDim arrData(lngRows) arrData(0) = oDocPassed.SelectContentControlsByTitle(strCCUnique).Item(1).Range.Text For lngRow = 1 To lngRows 'If Not oWS.Cells(lngRow, lngCol).Text = vbNullString Then 'arrData(lngRow) = WorksheetFunction.IfError(oWS.Cells(lngRow, lngCol), "") 'End If Select Case oWS.Cells(lngRow, lngCol).Text Case Is = "#DIV/0!", "#NUM!", "#VALUE!" Case Else arrData(lngRow) = oWS.Cells(lngRow, lngCol).Text End Select Next lngRow End If End If Next oILS fcnGetEmbeddedLabData = arrData() lbl_Exit: Set oWB = Nothing: Set oWS = Nothing Exit Function End Function If I stet out the Select Case stuff and use just your suggestion, then 1) The dates appeared in the extracted data as long values and 2) Many of the fields in the embedded sheet were extracted as "0" If I wrapped your suggested line in the IF ... End If statement, that resolves the "0" issue, but not the long values for dates. Any ideas? Thanks. |
#6
|
|||
|
|||
Andrew,
Monkey learns! I figured out how to employ your IsError function without affecting the date values: Code:
Function fcnGetEmbeddedLabData(oDocPassed As Object) As String() Dim oILS As InlineShape Dim oWS As Worksheet Dim oWB As Workbook Dim lngRow As Long, lngCol As Long Dim lngRows As Long Dim arrData() As String For Each oILS In oDocPassed.InlineShapes If oILS.Type = wdInlineShapeEmbeddedOLEObject Then If oILS.OLEFormat.progID = "Excel.Sheet.12" Then oILS.OLEFormat.Edit 'Set oWB = Workbooks(2) Set oWB = oILS.OLEFormat.Object Set oWS = oWB.Sheets(1) lngCol = oWS.Cells(2, oWS.Columns.Count).End(xlToLeft).Column lngRows = oWS.Cells(Rows.Count, "A").End(xlUp).Row ReDim arrData(lngRows) arrData(0) = oDocPassed.SelectContentControlsByTitle(strCCUnique).Item(1).Range.Text For lngRow = 1 To lngRows If WorksheetFunction.IsFormula(oWS.Cells(lngRow, lngCol)) Then arrData(lngRow) = WorksheetFunction.IfError(oWS.Cells(lngRow, lngCol), "") Else arrData(lngRow) = oWS.Cells(lngRow, lngCol).Text End If ' Select Case oWS.Cells(lngRow, lngCol).Text ' Case Is = "#DIV/0!", "#NUM!", "#VALUE!" ' Case Else ' arrData(lngRow) = oWS.Cells(lngRow, lngCol).Text ' End Select Next lngRow End If End If Next oILS fcnGetEmbeddedLabData = arrData() lbl_Exit: Set oWB = Nothing: Set oWS = Nothing Exit Function End Function |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Extract data from a Word file. | donlincolnmsof | Word VBA | 3 | 08-31-2019 05:27 AM |
Extract data from HTML File. | donlincolnmsof | Word VBA | 5 | 08-26-2019 08:36 PM |
Extract data from HTML File. | donlincolnmsof | Word VBA | 0 | 03-07-2019 12:17 PM |
Outlook 2013 Forms (how to questions)- Quick opening of a form file & Linking form's data to Excel | gamin2407 | Outlook | 0 | 01-21-2017 10:14 PM |
Macro to highlight repeated words in word file and extract into excel file | aabri | Word VBA | 1 | 06-14-2015 07:20 AM |