copy a specific words to excel list

romanticbiro · #1 06-29-2014, 02:05 PM

hello my friends

please, i need to do this senario
i've big arabic files need to coppy any word contains a specific letter to excel list, word may followed by space, paragraph mark or punctuation marks.
for example coppy any word contains U+649 (ى( to excel sheet, *.doc in this foldar.
am using word 2003
thanks

macropod · #2 06-29-2014, 04:03 PM

Is this macro to be run from Word, or from Excel? Is it adding words to an existing list, or is it creating a new list? How is the macro to identify the Excel workbook & worksheet and the Word document?

romanticbiro · #3 06-30-2014, 05:34 AM

hello dear,

yes this macro run from word,
note: need to save it in plank document to not write it each time i need to run,
it open any *.doc file found in its foldar, and coppy any word contains a specific letter to an excel_file named Word_List.xls
if available create a sheet in this file by name of each document

my idea to make foldar contain word file has this macro and beside it excel file Word_List, and any word files need to process will put them in this foldar and run macro.
is this possible?

thanks

macropod · #4 06-30-2014, 07:29 PM

Since you want to get a whole folder full of data, all on different worksheets, this would be better with an Excel macro instead of a Word macro. Simply add the following macro to an Excel workbook, then run it. Note that the code requires a reference to the Word object model. To do this in the VBE, choose Tools|References then scroll down to the Microsoft Word entry and check it.

Code:

Sub GetWordLists()
     'Note: this code requires a reference to the Word object model
    Application.ScreenUpdating = False
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Dim strFolder As String, strFile As String
    Dim WkBk As Workbook, WkSht As Worksheet, i As Long
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    Set WkBk = ThisWorkbook
    strFile = Dir(strFolder & "\*.docx", vbNormal)
    While strFile <> ""
        Set WkSht = WkBk.Sheets.Add
        i = 1
        WkSht.Cells(i, 1) = strFolder & "\" & strFile
        WkSht.Cells(i, 2) = "Page"
        WkSht.Name = Split(strFile, ".doc")(0)
        Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
        With wdDoc
            With .Range
                With .Find
                    .ClearFormatting
                    .Replacement.ClearFormatting
                    .Text = ChrW(&H649)
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = wdFindStop
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute
                End With
                Do While .Find.Found
                    i = i + 1
                    WkSht.Cells(i, 1) = Trim(.Duplicate.Words.First.Text)
                    WkSht.Cells(i, 2) = .Duplicate.Information(wdActiveEndAdjustedPageNumber)
                    .Collapse wdCollapseEnd
                    .Find.Execute
                Loop
            End With
            .Close SaveChanges:=False
        End With
        strFile = Dir()
    Wend
    wdApp.Quit
    Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
    Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

In addition to listing the words, the macro also outputs the pages on which they appear. No attempt is made to check for or remove duplicates.

romanticbiro · #5 07-01-2014, 05:12 AM

dear thanks for your advice
i tested it, but it coppy only one word then give me errowr as below,
Microsoft Visual Basic Run-time error '-2147417851 (80010105)':
Method 'Information' of object 'Range' failed
Continue, End, Debug, Help

note: not important for me to get page number, if it makes problem, specially it not wrote page number front of the word.

thanks very much for your care

macropod · #6 07-01-2014, 07:03 AM

When it gives that error message, what code line is highlighted? You may need to choose 'Debug'.

romanticbiro · #7 07-01-2014, 11:39 AM

hello dear

it gave this errowr after running a macro, mostly cause of page number cause the macro create sheet by file-name successfully and coppy first word without page number then stopp and gave the errowr message,
highlighted code-line:
WkSht.Cells(i, 2) = .Duplicate.Information(wdActiveEndAdjustedPageNumb er)

last part PageNumber)

thanks

romanticbiro · #8 07-01-2014, 11:48 AM

sorry highlighted line

WkSht.Cells(i, 2) = .Duplicate.Information(wdActiveEndAdjustedPageNumb er)

macropod · #9 07-01-2014, 02:52 PM

OK, you can delete that line - it's the one that outputs the page #

romanticbiro · #10 07-02-2014, 03:58 PM

dear Paule

thanks, it work excellent after i put apostrophy ' before this line to ignore it.
last thing, could i put a line to remove duplicate words?
many thanks

macropod · #11 07-02-2014, 04:46 PM

The best way to remove duplicates would be to sort the worksheet after it's been updated, then remove the duplicates. So, after:
wdApp.Quit
insert:

Code:

Dim lRow As Long, j As Long
With WkBk
  For i = 1 To .Worksheets.Count
    With .Worksheets(i)
      lRow = .UsedRange.Rows.Count
      For j = lRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(.Columns(1), .Range("A" & j)) > 1 Then
          .Range("A" & j).EntireRow.Delete
        End If
      Next j
    End With
  Next i
End With

romanticbiro · #12 12-03-2014, 04:48 AM

dear paul

i need your help in something, could i ask u?

macropod · #13 12-03-2014, 05:12 AM

If you need help with something start a thread. Someone, not necessarily me, may be able to provide a solution.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Find specific rows then copy and paste to new doc	konopca	Word VBA	5	02-20-2014 02:34 PM
How to allow specific double words in spellcheck	Wyndham	Word	5	02-06-2014 10:44 AM
Need VBA For Macro On How To Remove Specific Words	netchie	Word VBA	6	08-28-2012 03:37 PM
Macro to copy specific columns in Excel from another spreadsheet	KD999	Excel Programming	1	07-20-2012 08:58 AM
Macro for highlighting specific number of words	icsjohn	Word VBA	2	12-07-2011 06:44 PM