Extract unique numbers from Word and search for them in Excel

Hello,

I have two documents. One worddocument with different product id:s, and a excelfile with hopefully the same numbers

I want to build a macro that does following:

1. Search for all numbers after the term "PRODID:" in the whole word document.
2. See if these words can be found in the excelfile.
3. Display the numbers who are in the worddocument but not in the exceldocument.


I now have a short macro that can search the excel document but it requires me to manually copy all the ID-numbers from word to a excel sheet.

I appreciate all help i can get!!

hi Reen, welcome to ExcelForum, can you provide Excel and Word file in question?

Hello,

Thank you!

Here is testfiles, the entire document is over 2000 pages and is confidential so i cant share it.

Something worth knowing is that all documents are different in design. But the ID is always on the form

"REQID XXXXXX/" or "REQID:XXXXXX/".
Where XXXXXX is the ID-number with 4-7 digits.

And i dont want to extract number who isnt in that form.

In the exceldocument the Id is just in the form "XXXXXX"

I want to search for the words in all of the sheets in the exceldokument, and every cell.
Tell me if im confusing you!


Thanks!

please check attachment, press Run button or run code "test"

oops...I've noticed a mistake in the code, rectified, please check attachment

Originally Posted by watersev

oops...I've noticed a mistake in the code, rectified, please check attachment

Ive discovered one error cause of my misstake. I said that the word before the number war REQID but in fact it is REQPROD. When i changed REQID to REQPROD in the code i get "subscript out of range", do you know why?

This should do

Sub test()
    Dim fn As String, txt As String, e, m As Object
    Dim dic As Object, a(), n As Long
    fn = Application.GetOpenFilename("Word,*.doc*")
    If fn = "False" Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    For Each e In Range("a3", Range("a" & Rows.Count).End(xlUp)).Value
        If e <> "" Then dic(e) = Empty
    Next
    With CreateObject("Word.application")
        txt = .documents.Open(fn).Content
        .Quit
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "REQPROD[ :]*(\d{4,7})"
        For Each m In .Execute(txt)
            If Not dic.exists(m.submatches(0)) Then
                n = n + 1
                ReDim Preserve a(1 To n)
                a(n) = m.submatches(0)
                dic(m.submatches(0)) = Empty
            End If
        Next
    End With
    If n < 1 Then
        MsgBox "No new ID"
    Else
        MsgBox n & " new id found"
        Range("a" & Rows.Count).End(xlUp)(2).Resize(n).Value = _
        Application.Transpose(a)
    End If
End Sub

Originally Posted by jindon

This should do

Sub test()
    Dim fn As String, txt As String, e, m As Object
    Dim dic As Object, a(), n As Long
    fn = Application.GetOpenFilename("Word,*.doc*")
    If fn = "False" Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    For Each e In Range("a3", Range("a" & Rows.Count).End(xlUp)).Value
        If e <> "" Then dic(e) = Empty
    Next
    With CreateObject("Word.application")
        txt = .documents.Open(fn).Content
        .Quit
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "REQPROD[ :]*(\d{4,7})"
        For Each m In .Execute(txt)
            If Not dic.exists(m.submatches(0)) Then
                n = n + 1
                ReDim Preserve a(1 To n)
                a(n) = m.submatches(0)
                dic(m.submatches(0)) = Empty
            End If
        Next
    End With
    If n < 1 Then
        MsgBox "No new ID"
    Else
        MsgBox n & " new id found"
        Range("a" & Rows.Count).End(xlUp)(2).Resize(n).Value = _
        Application.Transpose(a)
    End If
End Sub

Thank you very much!!! Works perfect
Is there a way to display the REQPROD that are NOT in the excel, rather than the ones who are?

I don't know how you want it.

Just used msgbox.

Sub test()
    Dim fn As String, txt As String, e, m As Object
    Dim dic As Object, a(), n As Long, msg As String
    fn = Application.GetOpenFilename("Word,*.doc*")
    If fn = "False" Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    For Each e In Range("a3", Range("a" & Rows.Count).End(xlUp)).Value
        If e <> "" Then dic(CStr(e)) = Empty
    Next
    With CreateObject("Word.application")
        txt = .documents.Open(fn).Content
        .Quit
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "REQPROD[ :]*(\d{4,7})"
        For Each m In .Execute(txt)
            If Not dic.exists(m.submatches(0)) Then
                n = n + 1: msg = msg & vbLf & m.submatches(0)
                ReDim Preserve a(1 To n)
                a(n) = m.submatches(0)
                dic(m.submatches(0)) = Empty
            End If
        Next
    End With
    If msg = "" Then
        MsgBox "No new ID"
    Else
        MsgBox n & " new id found" & msg
        Range("a" & Rows.Count).End(xlUp)(2).Resize(n).Value = _
        Application.Transpose(a)
    End If
End Sub

Originally Posted by jindon

I don't know how you want it.

Just used msgbox.

Sub test()
    Dim fn As String, txt As String, e, m As Object
    ... 
        Application.Transpose(a)
    End If
End Sub

My bad, i missunderstood what the program did at first!

When i extract all REQPROD with your code, i want to compare them with the exceldocument with the following code:

Private Sub CommandButton1_Click()

    Dim CompareRange As Variant, x As Variant, y As Variant
    Dim fName As String
    Dim shName As String
    
    Set CompareRange = Workbooks("FileName").Worksheets("SheetName").Range("A:A")

    For Each x In Selection
        For Each y In CompareRange
            If x = y Then x.Offset(0, 1) = x
        Next y
    Next x
    
    MsgBox "Done"
End Sub

And it works sometimes but most it doesnt!

I would like to change:
Set CompareRange = Workbooks("FileName").Worksheets("SheetName").Range("A:A")

so that the user can insert the excelfile and search the whole document including all sheets and all cells.
How do i do that?

So, you want to compare the result with the data in another workbook.
Something like. (not tested)

Private Sub CommandButton1_Click()
    Dim ws As WorkSheet, a, e, dic as object, r As Range
    Set dic = CreateObject("Sripting.Dictionary")
    With WorkBooks("FileName")
        For Each ws In .Worksheets
            a = ws.UsedRange.Value
            If IsArray(a) Then
                For Each e In a
                    If e <> "" Then dic(e) = Empty
                Next
            End if
        Next
    End With
    For Each r In Selection
        If dic.Exists(r.Value) Then r(,2).Value = r.Value
    Next
End Sub

Excactly! Your code does not create any error but it doenst work. Nothing happends when i run it. Do you know what the problem may be?

Did you select the result range before you run the code?

Yes! I added a MsgBox in the end and i can tell it runs very quick.
In the exceldocument i want to search in the REQPROD-number isnt lined up as in te result range, the numbers can be wrapped in text etc.

I need to see the file...

Does it help if i say that the first row is a drpo-down list? and row 2 and -> is content in the list.

No, I need to see that data to be compared to the result....

Can i give u the content of one cell? I cant share the document and its to big to change the content of the whole file..

All your result consists of numeric value...

What are the data to be compared?

Originally Posted by jindon

All your result consists of numeric value...

What are the data to be compared?

For example, this is the content in ONE cell. And one cell can contain many REQPROD.

ID: 73819
Object Text: 

......
* 

Table: Requirements ..


Notes in the table ....

1
********* 
Refer to section 



c. Whenever the has responded:

********** 
session transition regardless if it is to the same or another session.


3
**********
14

ID: 156789

How about

Private Sub CommandButton1_Click()
    Dim ws As WorkSheet, a, e, dic as object, r As Range,m As Object
    Set dic = CreateObject("Sripting.Dictionary")
    With WorkBooks("FileName")
        For Each ws In .Worksheets
            a = ws.UsedRange.Value
            With CreateObject("VBScript.RegExp")
                .Global = True
                .Pattern = "ID: *(\d+)"
                If IsArray(a) Then
                    For Each e In a
                        For Each m In .Execute(e)
                            dic(val(m.submatches(0))) = Empty
                        Next
                    Next
                Else
                    For Each m In .Execute(a)
                        dic(val(m.submatches(0))) = Empty
                    Next
                End if
            End With
        Next
    End With
    For Each r In Selection
        If dic.Exists(r.Value) Then r(,2).Value = r.Value
    Next
End Sub

OK

Private Sub CommandButton1_Click()
    Dim ws As WorkSheet, a, e, dic as object, r As Range,m As Object
    Dim fn As String
    fn = Application.GetOpenFilename("Excel,*.xls*")
    If fn = "False" Then Exit Sub
    Set dic = CreateObject("Sripting.Dictionary")
    With WorkBooks(fn)
        For Each ws In .Worksheets
            a = ws.UsedRange.Value
            With CreateObject("VBScript.RegExp")
                .Global = True
                .Pattern = "ID: *(\d+)"
                If IsArray(a) Then
                    For Each e In a
                        For Each m In .Execute(e)
                            dic(val(m.submatches(0))) = Empty
                        Next
                    Next
                Else
                    For Each m In .Execute(a)
                        dic(val(m.submatches(0))) = Empty
                    Next
                End if
            End With
        Next
    End With
    For Each r In Selection
        If dic.Exists(r.Value) Then r(,2).Value = r.Value
    Next
End Sub

Thank you!

I get an subscript out of range error, debugger says this is the problem

With Workbooks(fn)

Of course...

    With WorkBooks.Open(fn)
        For Each ws In .Worksheets
            a = ws.UsedRange.Value
            With CreateObject("VBScript.RegExp")
                .Global = True
                .Pattern = "ID: *(\d+)"
                If IsArray(a) Then
                    For Each e In a
                        For Each m In .Execute(e)
                            dic(val(m.submatches(0))) = Empty
                        Next
                    Next
                Else
                    For Each m In .Execute(a)
                        dic(val(m.submatches(0))) = Empty
                    Next
                End if
            End With
        Next
        .Close False
    End With