|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Need help with VBA macro to copy text from Word to Excel according to a list
Hello everyone,
I'm looking for help with a VBA macro that can automatically copy text from a Word document and paste it into Excel, according to a list of names. Here's what I'm currently using: 1. Highlight text in Word document according to a list of names. Code:
Sub Highlight_Words_From_Excel_NamedRange() Const strWorkbook As String = "E:\Database\wordlist.xlsx" Const strRange As String = "WordList" Dim arr() As Variant Dim lngRows As Long Dim oRng As Range Dim strFind As String arr = xlFillArray(strWorkbook, strRange) For lngRows = 0 To UBound(arr, 2) strFind = arr(0, lngRows) Set oRng = ActiveDocument.Range With oRng.Find Do While .Execute(findText:=strFind) oRng.HighlightColorIndex = wdTurquoise oRng.Collapse 0 Loop End With Next lngRows lbl_Exit: Exit Sub End Sub Private Function xlFillArray(strWorkbook As String, _ strRange As String) As Variant Dim RS As Object Dim CN As Object Dim iRows As Long strRange = strRange & "]" Set CN = CreateObject("ADODB.Connection") CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & strWorkbook & ";" & _ "Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1""" Set RS = CreateObject("ADODB.Recordset") RS.Open "SELECT * FROM [" & strRange, CN, 2, 1 With RS .MoveLast iRows = .RecordCount .MoveFirst End With xlFillArray = RS.GetRows(iRows) If RS.State = 1 Then RS.Close Set RS = Nothing If CN.State = 1 Then CN.Close Set CN = Nothing lbl_Exit: Exit Function End Function Code:
Sub CopyHighlightsToOtherDoc() Dim ThisDoc As Document Dim ThatDoc As Document Dim r As Range Set ThisDoc = ActiveDocument Set r = ThisDoc.Range Set ThatDoc = Documents.add With r With .Find .Text = "" .Highlight = True .Font.Name = "Times New Roman" .Font.Bold = True End With Do While .Find.Execute(Forward:=True) = True ThatDoc.Range.Characters.Last.FormattedText = .FormattedText ThatDoc.Range.InsertParagraphAfter .Collapse 0 Loop End With End Sub 4. Copy the text from the second Word document and paste it into Excel. I've tried using several macros to accomplish this, but the process is quite time-consuming. I'm hoping that someone can help me write a VBA macro that can automate this process and make it more efficient. Any help or suggestions would be greatly appreciated. Thank you! |
#2
|
|||
|
|||
Plop this into an Excel module
You'll need to make a word document with a populated 2 column table and save it someplace. In the Runme procedure, run or press F5 Code:
Option Explicit ' Helps to ensure your code is good Sub Runme() '*** Run this procedure 'Require Reference to Microsoft Word 16.0 Object Library 'This code will work for a standard word document with at least one 2 column table Dim wdApp As Word.Application Dim WdDoc As Word.Document Dim wdTable As Word.Table Dim i As Integer On Error GoTo ErrHandler Set wdApp = CreateObject("Word.Application") ' Open Word document Set WdDoc = wdApp.Documents.Open(OpenFile) ' Open the word document - Will run the function above Set wdTable = WdDoc.Tables(1) ' Reference table by number ' **** Activate if you want to see the Doc. otherwise, leave outta sight for speed. 'wrdApp.Visible = True 'wrdApp.Activate 'Copies Cell to Excel by looping through each row in the word document. 'Cell(i,1) is first column, Cell(i,2) is second column. With wdTable For i = 1 To .Rows.Count 'Sheet1 (Excel) = Word table cell Sheet1.Cells(i, 1).Value = CorrectCellString(.Cell(i, 1).Range.Text) Sheet1.Cells(i, 2).Value = CorrectCellString(.Cell(i, 2).Range.Text) Next i End With Sheet1.Cells(1, 1).Select ' Return cell selection to row 1, column 1 Finishup: 'Close Doc and Release WdDoc.Close wdApp.Quit Set wdApp = Nothing Set WdDoc = Nothing Set wdTable = Nothing Exit Sub ErrHandler: MsgBox Err.Number & vbCrLf & Err.Description ' Tell me what went wronog GoTo Finishup End Sub Function CorrectCellString(StrString As String) As String 'Purpose: correct the cell string from word - removes paragraph markers, etc CorrectCellString = Left(StrString, Len(StrString) - 2) End Function Function OpenFile() As String 'Opens Word document from user selection Dim fd As Office.FileDialog Dim strFile As String Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Filters.Clear .Filters.Add "Word Files", "*.docx", 1 .Title = "Choose an Excel file" .AllowMultiSelect = False .InitialFileName = "C:\VBA Folder" If .Show = True Then strFile = .SelectedItems(1) OpenFile = strFile End If End With End Function |
#3
|
|||
|
|||
Quote:
|
#4
|
|||
|
|||
Hi.
I'm sorry this didn't work for you first time. This strikes me as an odd error, however, I have tested this from a different PC and it works as intended. I've added two files as an attachment to this message. - a basic word doc with a table - save to a temp folder - an excel SS with a button included on the sheet. the button is the only real addition. Click the button and point the dialog to the word doc. Note that the word table only contains a couple rows, but you can add more - and more info into the second column also. Try again - hope it works this time. Cheers |
#5
|
|||
|
|||
Quote:
Code:
Option Explicit Private Const xlWB As String = "C:\Path\Empty Excel File name.xlsx" Private Const xlSheet As String = "Sheet1" Sub ExtractText() Dim oDoc As Document Dim oRng As Range Set oDoc = ActiveDocument Set oRng = oDoc.Range With oRng.Find .ClearFormatting .Replacement.ClearFormatting .Font.Name = "Times New Roman" .Font.Bold = True Do While .Execute() If oRng.Text Like "Speaker*" Then WriteToWorksheet xlWB, xlSheet, oRng.Text End If Loop End With lbl_Exit: Exit Sub End Sub Private Function WriteToWorksheet(strWorkbook As String, _ strRange As String, _ strValues As String) Dim ConnectionString As String Dim strSQL As String Dim CN As Object ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & strWorkbook & ";" & _ "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";" strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')" Set CN = CreateObject("ADODB.Connection") Call CN.Open(ConnectionString) Call CN.Execute(strSQL, , 1 Or 128) CN.Close Set CN = Nothing lbl_Exit: Exit Function End Function |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
How to copy text from Word to Excel according to a list? | syl3786 | Word VBA | 6 | 04-09-2023 08:01 AM |
Text To Copy From Excel To Relevant Word Document | Covert Codger | Word VBA | 4 | 07-27-2022 11:40 PM |
a macro that can copy data from copy.xls to our current excel macro.xls based on criteria: | udhaya | Excel Programming | 1 | 11-12-2015 10:12 AM |
how to copy addresses in word document to excel/mailmerge list | msnarayanan | Mail Merge | 4 | 10-17-2015 03:17 PM |
Copy Underline text from Word and Paste into excel | rfaris | Excel Programming | 7 | 10-05-2015 05:56 AM |