Match and Modify serial number data using VBA

[Carlit007]

Hi I am trying to find out if there's a way to do the following using VBA

I have a workbook with data from a report like the one below consisting of equipment serial numbers
The Items Highlighted in blue are Serial numbers for equipment I have in different locations

worksheet 2 has the Serial numbers I constantly track on Colum A, followed by the location on Colum J

what I would like is for the data imported from a new report in worksheet 1 to find and match the serial number by looking at worksheet 2 and basically adding the location information from colum j right next to the Serial number all in worksheet 1 I have done this in the past by doing vlookup but it is very time consuming as I have to paste the formula right next to an empty cell next to the Serials numbers. what is the best way to go about this thanks in advance

 

[Carlit007]

@kennypete not sure if I could find the following in this Forum but I was wondering If it is possible to do the following;
instead of running the code on a Excel sheet I was wondering If I could run it to link the Location Data from excel to a MS word Document as the output

The reason being sometimes when I convert the reports to Excel some of the formatting is lost I have found out that MS word does a better job from at maintaining the correct formatting.

 

[kennypete]

Sorry, are you saying
1. could the code be modified to Word VBA and run on two Word files instead of Excel sheets?
2. could the code be modified to Word VBA and run on a Word file reading an Excel sheet?
3. could the code be modified to run on a Word file reading an Excel sheet with the existing Excel VBA?
4. could the output from the current process be "copied" to a Word file?
5. something else?

 

[Carlit007]

Sorry, are you saying
1. could the code be modified to Word VBA and run on two Word files instead of Excel sheets?
2. could the code be modified to Word VBA and run on a Word file reading an Excel sheet?
3. could the code be modified to run on a Word file reading an Excel sheet with the existing Excel VBA?
4. could the output from the current process be "copied" to a Word file?
5. something else?

I would say Option 2 is the closest if not also open option 3

I am just learning VBA in excel not sure if its completely different in MS word but I figure I would stay where I'm more comfortable.

1. the Location for each serialized equipment will be maintained in the sheet with the location data in excel
2. I will receive a monthly report which I will then convert to word because It does a better job at maintaining the formatting (as opposed to exporting to excel)
3. I will then run the the vba code from excel and it will match the serial numbers inside word and transfer all the location data to the word files from step 2 (my step 2)

If its easier to run the VBA from MS word so that it will look at the excel file for the answer then I am also open for that again I am just more familiar with VBA writhing excel

 

[kennypete]

Okay, here's the solution using 'Option 2'. Funnily enough it's easier to do than with Excel sheets since Word is more attune to doing formatting search and replaces.

Sub subAddLocationsV5()
    ' The Serial Numbers are unique primary keys. In this case, because there's
    ' a known fixed number of them, I've used an array to store those keys.
    Dim aKeys As Variant
    ' The Sheet **Code Name** is sh2, its **Name** is "Serials" (what appears on the Tab)
    aKeys = sh2.Range("A2:A8").Value
    ' The corresponding items are the locations. For each of the Serial Number keys
    ' store the locations in the same position in another array.
    Dim aItems As Variant
    aItems = sh2.Range("D2:D8").Value
    ' Declaring "i" as an integer for doing the loops
    Dim i As Integer
    ' Dimension the MS Word objects
    Dim WordApp As Object, WordDoc As Object
    Set WordApp = CreateObject(Class:="Word.Application")
    'Set WordApp = GetObject(, "Word.Application")
    WordApp.Visible = True
    Set WordDoc = WordApp.Documents.Open("D:\_Share\20200312\1125504.docx")
    With WordApp
        For i = 1 To UBound(aKeys)
            ' Search for the Serial number. Because of the way the array aKeys is created it
            ' creates a 2D array, with the Serial numbers being in #1 of the second dimension
            ' e.g. 4THGPL2 is in aKeys(1, 1), 700GPL2 in aKeys (2, 1) and so on. The find text
            ' is the key, e.g. aKeys(1, 1) / 700GPL2, the replace text is that plus a space
            ' plus the item fron the Location array, so, e.g. aItems(1, 1)  / NGMANB301E80013
            ' (SJ) RM 211 (DESK 2).
            With WordDoc.Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = aKeys(i, 1)
                .Replacement.Text = aKeys(i, 1) & " " & aItems(i, 1)
                .Forward = True
                .Wrap = 1 ' = wdFindContinue if in Word
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2 ' wdReplaceAll if in Word
            End With
            With WordDoc.Content.Find
                .ClearFormatting
                .Replacement.Font.Bold = True
                .Replacement.Font.Color = vbBlue ' R0,G0,B255
                .Text = aItems(i, 1)
                .Replacement.Text = ""
                .Forward = True
                .Wrap = 1 ' = wdFindContinue if in Word
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2 ' wdReplaceAll if in Word
            End With
        Next
    End With
    WordApp.ActiveDocument.Save
    WordApp.ActiveDocument.Close
    WordApp.Quit
    Set WordApp = Nothing
    Set WordDoc = Nothing
End Sub

This is hardcoded to the Word file D:\_Share\20200312\1125504.docx so you'll need to adjust that.
I've snapped a few screenshots in this GIF, showing stepping the macro, it opening Word, and doing the Find/Replace. Note I stopped it with the breakpoint at the ".Save".

 

[kennypete]

Okay, here's the solution using 'Option 2'.

I meant Option 3: this solution is still run from Excel!

 

[Carlit007]

Wow I cant wait to try this I was thinking perhaps adding a message box that pops up asking you to select the word file (or files)that way wont need to keep changing the address in vba

 

[Carlit007]

Okay, here's the solution using 'Option 2'. Funnily enough it's easier to do than with Excel sheets since Word is more attune to doing formatting search and replaces.

Sub subAddLocationsV5()
    ' The Serial Numbers are unique primary keys. In this case, because there's
    ' a known fixed number of them, I've used an array to store those keys.
    Dim aKeys As Variant
    ' The Sheet **Code Name** is sh2, its **Name** is "Serials" (what appears on the Tab)
    aKeys = sh2.Range("A2:A8").Value
    ' The corresponding items are the locations. For each of the Serial Number keys
    ' store the locations in the same position in another array.
    Dim aItems As Variant
    aItems = sh2.Range("D2:D8").Value
    ' Declaring "i" as an integer for doing the loops
    Dim i As Integer
    ' Dimension the MS Word objects
    Dim WordApp As Object, WordDoc As Object
    Set WordApp = CreateObject(Class:="Word.Application")
    'Set WordApp = GetObject(, "Word.Application")
    WordApp.Visible = True
    Set WordDoc = WordApp.Documents.Open("D:\_Share\20200312\1125504.docx")
    With WordApp
        For i = 1 To UBound(aKeys)
            ' Search for the Serial number. Because of the way the array aKeys is created it
            ' creates a 2D array, with the Serial numbers being in #1 of the second dimension
            ' e.g. 4THGPL2 is in aKeys(1, 1), 700GPL2 in aKeys (2, 1) and so on. The find text
            ' is the key, e.g. aKeys(1, 1) / 700GPL2, the replace text is that plus a space
            ' plus the item fron the Location array, so, e.g. aItems(1, 1)  / NGMANB301E80013
            ' (SJ) RM 211 (DESK 2).
            With WordDoc.Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = aKeys(i, 1)
                .Replacement.Text = aKeys(i, 1) & " " & aItems(i, 1)
                .Forward = True
                .Wrap = 1 ' = wdFindContinue if in Word
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2 ' wdReplaceAll if in Word
            End With
            With WordDoc.Content.Find
                .ClearFormatting
                .Replacement.Font.Bold = True
                .Replacement.Font.Color = vbBlue ' R0,G0,B255
                .Text = aItems(i, 1)
                .Replacement.Text = ""
                .Forward = True
                .Wrap = 1 ' = wdFindContinue if in Word
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2 ' wdReplaceAll if in Word
            End With
        Next
    End With
    WordApp.ActiveDocument.Save
    WordApp.ActiveDocument.Close
    WordApp.Quit
    Set WordApp = Nothing
    Set WordDoc = Nothing
End Sub

This is hardcoded to the Word file D:\_Share\20200312\1125504.docx so you'll need to adjust that.
I've snapped a few screenshots in this GIF, showing stepping the macro, it opening Word, and doing the Find/Replace. Note I stopped it with the breakpoint at the ".Save".

View attachment 8810

wow it does take a lot longer when using word but It worked perfectly! thank you so Much for your time in this project I definitely learned much from this

 

[kennypete]

All good @Carlit007 - if you want the file open dialog version, here it is:

Sub subAddLocationsV6()
    ' The Serial Numbers are unique primary keys. In this case, because there's
    ' a known fixed number of them, I've used an array to store those keys.
    Dim aKeys As Variant
    ' The Sheet **Code Name** is sh2, its **Name** is "Serials" (what appears on the Tab)
    aKeys = sh2.Range("A2:A8").Value
    ' The corresponding items are the locations. For each of the Serial Number keys
    ' store the locations in the same position in another array.
    Dim aItems As Variant
    aItems = sh2.Range("D2:D8").Value
    ' Declaring "i" as an integer for doing the loops
    Dim i As Integer
    ' Dimension the MS Word objects
    Dim WordApp As Object, WordDoc As Object
    Set WordApp = CreateObject(Class:="Word.Application")
    ' Select the .docx file
    Dim strDocx As String
    strDocx = funSelectDocx()
    WordApp.Visible = True
    Set WordDoc = WordApp.Documents.Open(strDocx)
    With WordApp
        For i = 1 To UBound(aKeys)
            ' Search for the Serial number. Because of the way the array aKeys is created it
            ' creates a 2D array, with the Serial numbers being in #1 of the second dimension
            ' e.g. 4THGPL2 is in aKeys(1, 1), 700GPL2 in aKeys (2, 1) and so on. The find text
            ' is the key, e.g. aKeys(1, 1) / 700GPL2, the replace text is that plus a space
            ' plus the item fron the Location array, so, e.g. aItems(1, 1)  / NGMANB301E80013
            ' (SJ) RM 211 (DESK 2).
            With WordDoc.Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = aKeys(i, 1)
                .Replacement.Text = aKeys(i, 1) & " " & aItems(i, 1)
                .Forward = True
                .Wrap = 1 ' = wdFindContinue if in Word
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2 ' wdReplaceAll if in Word
            End With
            With WordDoc.Content.Find
                .ClearFormatting
                .Replacement.Font.Bold = True
                .Replacement.Font.Color = vbBlue ' R0,G0, B255
                .Text = aItems(i, 1)
                .Replacement.Text = ""
                .Forward = True
                .Wrap = 1 ' = wdFindContinue if in Word
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2 ' wdReplaceAll if in Word
            End With
        Next
    End With
    WordApp.ActiveDocument.Save
    WordApp.ActiveDocument.Close
    WordApp.Quit
    Set WordApp = Nothing
    Set WordDoc = Nothing
End Sub
Function funSelectDocx() As String
    Dim dlgFileDialog As FileDialog
    Dim varCurrentPathAndFilename As Variant
    Set dlgFileDialog = Application.FileDialog(msoFileDialogOpen)
    dlgFileDialog.Title = "Open"
    dlgFileDialog.Filters.Clear
    dlgFileDialog.Filters.Add "Word Documents", "*.docx"
    dlgFileDialog.AllowMultiSelect = False
    ' If a file is selected from the dialog box...
    If dlgFileDialog.Show = -1 Then
        funSelectDocx = dlgFileDialog.SelectedItems(1)
    Else
        MsgBox "No *.docx file was selected", Title:="Open"
    End If
End Function

 

[Carlit007]

All good @Carlit007 - if you want the file open dialog version, here it is:

Sub subAddLocationsV6()
    ' The Serial Numbers are unique primary keys. In this case, because there's
    ' a known fixed number of them, I've used an array to store those keys.
    Dim aKeys As Variant
    ' The Sheet **Code Name** is sh2, its **Name** is "Serials" (what appears on the Tab)
    aKeys = sh2.Range("A2:A8").Value
    ' The corresponding items are the locations. For each of the Serial Number keys
    ' store the locations in the same position in another array.
    Dim aItems As Variant
    aItems = sh2.Range("D2:D8").Value
    ' Declaring "i" as an integer for doing the loops
    Dim i As Integer
    ' Dimension the MS Word objects
    Dim WordApp As Object, WordDoc As Object
    Set WordApp = CreateObject(Class:="Word.Application")
    ' Select the .docx file
    Dim strDocx As String
    strDocx = funSelectDocx()
    WordApp.Visible = True
    Set WordDoc = WordApp.Documents.Open(strDocx)
    With WordApp
        For i = 1 To UBound(aKeys)
            ' Search for the Serial number. Because of the way the array aKeys is created it
            ' creates a 2D array, with the Serial numbers being in #1 of the second dimension
            ' e.g. 4THGPL2 is in aKeys(1, 1), 700GPL2 in aKeys (2, 1) and so on. The find text
            ' is the key, e.g. aKeys(1, 1) / 700GPL2, the replace text is that plus a space
            ' plus the item fron the Location array, so, e.g. aItems(1, 1)  / NGMANB301E80013
            ' (SJ) RM 211 (DESK 2).
            With WordDoc.Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = aKeys(i, 1)
                .Replacement.Text = aKeys(i, 1) & " " & aItems(i, 1)
                .Forward = True
                .Wrap = 1 ' = wdFindContinue if in Word
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2 ' wdReplaceAll if in Word
            End With
            With WordDoc.Content.Find
                .ClearFormatting
                .Replacement.Font.Bold = True
                .Replacement.Font.Color = vbBlue ' R0,G0, B255
                .Text = aItems(i, 1)
                .Replacement.Text = ""
                .Forward = True
                .Wrap = 1 ' = wdFindContinue if in Word
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2 ' wdReplaceAll if in Word
            End With
        Next
    End With
    WordApp.ActiveDocument.Save
    WordApp.ActiveDocument.Close
    WordApp.Quit
    Set WordApp = Nothing
    Set WordDoc = Nothing
End Sub
Function funSelectDocx() As String
    Dim dlgFileDialog As FileDialog
    Dim varCurrentPathAndFilename As Variant
    Set dlgFileDialog = Application.FileDialog(msoFileDialogOpen)
    dlgFileDialog.Title = "Open"
    dlgFileDialog.Filters.Clear
    dlgFileDialog.Filters.Add "Word Documents", "*.docx"
    dlgFileDialog.AllowMultiSelect = False
    ' If a file is selected from the dialog box...
    If dlgFileDialog.Show = -1 Then
        funSelectDocx = dlgFileDialog.SelectedItems(1)
    Else
        MsgBox "No *.docx file was selected", Title:="Open"
    End If
End Function

@kennypete Hi Kenny its been a couple of years and I have since then moved my Excel database to MS Access because its just easier to run/update I was wondering If it would be easy to transfer this excel VBA code into Access. If I need to start a new tread I apologize just don't even know where to begin Access is all new to me

 

[kennypete]

@kennypete Hi Kenny its been a couple of years and I have since then moved my Excel database to MS Access because its just easier to run/update I was wondering If it would be easy to transfer this excel VBA code into Access. If I need to start a new tread I apologize just don't even know where to begin Access is all new to me

Yes, it would be best to start a new thread, especially as it is Access.