VBA to replace index matching.

[dougmarkham]

Hi Folks,

I am looking for a way using VBA to do the following process:

I have two worksheets: Sheet 1 (contains Table 1) and Sheet 2 (contains table 2).

Worksheet 1:

• Table 1 - Column A contains serial numbers.

Worksheet 2:

• Table 2 - Column A contains an index of all the serial numbers.
• Table 2 - Column B contains corresponding alpha numeric codes (one for each serial number).

Goal: I would like to run a macro which compares all the serial numbers in WkSht1 Table 1 - Col A with the index serial numbers in WkSht2 - Table 2 - Col A; once complete, I would like the VBA to copy the corresponding alpha numeric codes from WkSht2 - Col B and paste them over the serial numbers in WkSht1 - Col A.


For example:

Step 1: VBA would search Col A in Table 1, identifying them...

Worksheet 1 - Table 1
[TABLE="width: 500, align: left"]
<tbody>[TR]
[TD]Column A[/TD]
[TD]Column B[/TD]
[/TR]
[TR]
[TD]123457[/TD]
[TD]01/06/2018[/TD]
[/TR]
[TR]
[TD]123459[/TD]
[TD]01/06/2018[/TD]
[/TR]
</tbody>[/TABLE]






Step 2: VBA would match the identified serial numbers with those indexed in Table 2 - Col A:

Worksheet 2 - Table 2
[TABLE="width: 500, align: left"]
<tbody>[TR]
[TD]Column A[/TD]
[TD]Column B[/TD]
[/TR]
[TR]
[TD]123456[/TD]
[TD]ABC1[/TD]
[/TR]
[TR]
[TD]123457[/TD]
[TD]ABC2[/TD]
[/TR]
[TR]
[TD]123458[/TD]
[TD]ABC3[/TD]
[/TR]
[TR]
[TD]123459[/TD]
[TD]ABC4[/TD]
[/TR]
[TR]
[TD]123460[/TD]
[TD]ABC5[/TD]
[/TR]
</tbody>[/TABLE]










Then copy and paste the alpha-numeric codes back into Table 1 Column A (over-writing the serial codes).

Worksheet 1 - Table 1
[TABLE="width: 500"]
<tbody>[TR]
[TD]Column A[/TD]
[TD]Date[/TD]
[/TR]
[TR]
[TD]ABC2[/TD]
[TD]01/06/2018[/TD]
[/TR]
[TR]
[TD]ABC4[/TD]
[TD]01/06/2018[/TD]
[/TR]
</tbody>[/TABLE]


I have some code that matches and replaces data within two tables in the same worksheet; however, I would like some help modifying the code to do as outlined.

Sub Match & Replace
Dim rng as Range
Dim rngInspection as Range
 
Set rng = Range("B2:EX") -- Range of the left table
Set rngInspection = Range("O2:P5") -- Range of the right table
 
For Each rowInspection In rngInspection.Rows
 
   Dim part as string, serial as string, inspectionDate as String
   part = rowInspection.Cells(1).Value
   serial = rowInspection.Cells(2).Value
   inspectionDate = rowInspection.Cells(3)
 
   For Each row in rng.rows
       If (row.Cells(1).Value = part And row.Cells(2).Value = serial) Then
            row.Cells(4).Value = inspectionDate
       EndIf
   Next row
 
Next rowInspection

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG24Jan42
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng: [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Dn: [COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
 [COLOR="Navy"]If[/COLOR] .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
    .Item(Dn.Value).Value = Dn.Offset(, 1).Value
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[wideboydixon]

That method above is slow. Using a dictionary would be much quicker:

' Change these as appropriate
Private Const Sheet1Name = "Worksheet 1"
Private Const Sheet2Name = "Worksheet 2"
Private Const FirstRow = 1
Public Sub SerialToAlpha()

Dim myDic As Object
Dim lastRow As Long
Dim thisRow As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet

' Create the dictionary object
Set myDic = CreateObject("Scripting.Dictionary")

' Get references to the worksheets
Set ws1 = Worksheets(Sheet1Name)
Set ws2 = Worksheets(Sheet2Name)

' Populate the dictionary from the key/values in the second sheet
lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
For thisRow = FirstRow To lastRow
    If Not myDic.Exists(ws2.Cells(thisRow, "A").Value) Then
        myDic.Add ws2.Cells(thisRow, "A").Value, ws2.Cells(thisRow, "B").Value
    End If
Next thisRow

' Work through the first sheet and replace the values
lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
For thisRow = FirstRow To lastRow
    If myDic.Exists(ws1.Cells(thisRow, "A").Value) Then
        ws1.Cells(thisRow, "A").Value = myDic.Item(ws1.Cells(thisRow, "A").Value)
    End If
Next thisRow

End Sub

WBD

 

[dougmarkham]

That method above is slow. Using a dictionary would be much quicker:

' Change these as appropriate
Private Const Sheet1Name = "Worksheet 1"
Private Const Sheet2Name = "Worksheet 2"
Private Const FirstRow = 1
Public Sub SerialToAlpha()

Dim myDic As Object
Dim lastRow As Long
Dim thisRow As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet

' Create the dictionary object
Set myDic = CreateObject("Scripting.Dictionary")

' Get references to the worksheets
Set ws1 = Worksheets(Sheet1Name)
Set ws2 = Worksheets(Sheet2Name)

' Populate the dictionary from the key/values in the second sheet
lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
For thisRow = FirstRow To lastRow
    If Not myDic.Exists(ws2.Cells(thisRow, "A").Value) Then
        myDic.Add ws2.Cells(thisRow, "A").Value, ws2.Cells(thisRow, "B").Value
    End If
Next thisRow

' Work through the first sheet and replace the values
lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
For thisRow = FirstRow To lastRow
    If myDic.Exists(ws1.Cells(thisRow, "A").Value) Then
        ws1.Cells(thisRow, "A").Value = myDic.Item(ws1.Cells(thisRow, "A").Value)
    End If
Next thisRow

End Sub

WBD

Thanks MickG and WBD, both work perfectly.

WBD: your code using the 'dictionary object' works very quickly. I added:
Application.ScreenUpdating = False
Application.Calculation = xlManual
etc.

It completes almost instantly!

Thank you again.

Kind regards,

Doug.

P.S. my bored more juvenile colleagues especially enjoyed the line: If myDic.Exists...
Apparently they were surprised this line of code did not cause an excel error message.

 

[wideboydixon]

P.S. my bored more juvenile colleagues especially enjoyed the line: If myDic.Exists...
Apparently they were surprised this line of code did not cause an excel error message.

A colleague of mine once wanted to track the number of seconds it took for an analysis operation to complete. The variable name he chose? analSecs!

WBD

 

[dougmarkham]

A colleague of mine once wanted to track the number of seconds it took for an analysis operation to complete. The variable name he chose? analSecs!

WBD

LMAO....