copy a specific words to excel list

[romanticbiro]

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]

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]

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]

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.

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]

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]

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

[romanticbiro]

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]

sorry highlighted line

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

[macropod]

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

[romanticbiro]

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]

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:

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]

dear paul

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

[macropod]

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