Take Old Key value, Find equivalent New Key value, replace cell with Updated Key value

user_19156737 0
Viewed 41

I am new to VBA, and am an extremely bad coder to begin with.

Essentially what I need to do is take a product key value, compare that key value in a list of thousands, and replace that product key value with the new updated value.

I am a picture learner so this is what I am working with extremely simplified:

enter image description here

V

enter image description here

V

enter image description here

I have some code that I am currently writing, and have tried looking up a lot of different built in functions that I can work with, but I am really lost.

 Sub SwapNumbers()

 Dim OldNumber As Integer
 Dim myrange As Range
 Dim NewNumber As Integer

 ' Select Current Cell
 OldNumber = ActiveCell.Value

My first main question, is how do I set a variable to be able to cover a row range so large? I know I will have to change the variable type if I change it. But I am thinking is it possible to maybe do a loop that might be able to run through every row in a certain column until it finds the number then stops?

 'Compare Cell Value (Old Number) to List of Numbers (Col 1)

 Set myrange = Worksheets("Sheet 2").Range("A2:A1712")

 For Each cell In myrange

      If IsNumeric(Application.Match(OldNumber, myrange, 0)) Then
          NewNumber = myrange.Value
      End If

 Next

If that is the case, once I find that cell, how do I save it to then make sure I can move over to a new column to find the new product key value? 'If found Old number match (Col 1) jump to New number (Col 2)

And I guess this next part is pretty simple, I just have to figure out the correct syntax....

 'Input New number (Col 2) into selected cell


 End Sub

I hope this makes sense? I feel like I am vastly overcomplicating this. Or maybe not making it complicated enough. Who knows.

vba excel
2 Answers

I've gone overboard with the comments so that your 'newness' to VBA doesn't impede your understanding:

Sub SwapNumbers()
    Dim src As Range 'reference old data on worksheet
    Dim srcArr As Variant 'reference old data in memory
    Dim i As Long
    Dim current As Variant 'reference Match result
    Dim lookUp As Range ' reference 1st column of 'conversion table'
    Dim lookUpTable As Variant 'reference 1st 4 columns of 'conversion table' in memory
    
    Set src = Worksheets("Sheet1").Range("A3")     'assumed location of cell containing 'Product ID'
    Set lookUp = Worksheets("Sheet2").Range("A2") 'assumed location of cell containing 'OldProdID'
    Set src = Range(src, src.End(xlDown)).Resize(, 2) 'increase src for 1st 2 columns, and all rows (until blank)
    srcArr = src.Value2 'write src values to memory'
    Set lookUp = Range(lookUp, lookUp.End(xlDown))
    lookUpTable = Range(lookUp, lookUp.End(xlDown)).Resize(, 4).Value2
    
    For i = 2 To UBound(srcArr, 1)  'starting at 2 because headers in 1st position'
        current = Application.Match(srcArr(i, 1), lookUp, 0)
        If IsNumeric(current) Then
            srcArr(i, 1) = lookUpTable(current, 3)  'update with data from 3rd column of 'conversion table'
            srcArr(i, 2) = lookUpTable(current, 4)
        End If
    Next i
    
    src.Value2 = srcArr 'Overwrite src range with updated contents from memory
End Sub

(obviously the Set src and Set lookUp lines should be adjusted, as my assumptions probably don't represent the correct references of your actual cells)

user_188247270

Replace Numbers (Ids) Using a Dictionary

Sub ReplaceIds()
    
    ' Source
    Const sName As String = "Sheet2"
    Const slFirstCellAddress As String = "A3" ' l - Lookup
    Const svCol As String = "C" ' v - Value
    ' Destination
    Const dName As String = "Sheet1"
    Const dFirstCellAddress As String = "A4"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the ids to arrays.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim lCell As Range
    Dim slData As Variant
    Dim svData As Variant
    Dim rCount As Long
    
    With sws.Range(slFirstCellAddress)
        Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub ' no data in column range
        rCount = lCell.Row - .Row + 1
        With .Resize(rCount)
            If rCount = 1 Then ' one row
                ReDim slData(1 To 1, 1 To 1): slData(1, 1) = .Value
                ReDim svData(1 To 1, 1 To 1)
                svData(1, 1) = .EntireRow.Columns(svCol).Value
            Else ' multiple rows
                slData = .Value
                svData = .EntireRow.Columns(svCol).Value
            End If
        End With
    End With
    
    ' Write the ids (numbers) from the arrays to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim r As Long
    
    For r = 1 To rCount
        If VarType(slData(r, 1)) = vbDouble Then
            If VarType(svData(r, 1)) = vbDouble Then
                dict(slData(r, 1)) = svData(r, 1)
            End If
        End If
    Next r
    
    If dict.Count = 0 Then Exit Sub ' no numeric data
    
    ' Delete the arrays (the relevant data is in the dictionary).
    Erase slData
    Erase svData
    
    ' Write the destination ids from the range to an array.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    
    Dim drg As Range
    Dim dData As Variant
    
    With dws.Range(dFirstCellAddress)
        Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
           .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub ' no data in column range
        rCount = lCell.Row - .Row + 1
        Set drg = .Resize(rCount)
        If rCount = 1 Then ' one row
            ReDim dData(1 To 1, 1 To 1): dData(1, 1) = drg.Value
        Else ' multiple rows
            dData = drg.Value
        End If
    End With
    
    ' Loop through the values in the array to replace the old ids with new ones.
    For r = 1 To rCount
        If VarType(dData(r, 1)) = vbDouble Then
            If dict.Exists(dData(r, 1)) Then
                dData(r, 1) = dict(dData(r, 1))
            End If
        End If
    Next r
    
    ' Write the modified ids back to the range.
    drg.Value = dData
    
    ' Inform.
    MsgBox "Old ids replaced.", vbInformation
    
End Sub
user_98140690
Related