Macro to replace values in a range (similar to vlookup or index/match)

[ChristineJ]

Can a macro REPLACE all the numerical values in columns D through L (there will be at least 5,000 rows) with a value from column C?

The value in each cell in columns D through L matches one of the unique values in A2:A155. The value in column C on that same row as the match in column A should replace each original value.

Example 1: The value in E2 below is 3. That matches with the value in cell A4. The value in C4 is "Yellow". The word "Yellow" should replace the "3" in cell E2.

Example 2: The value in G4 below is 14. That matches with the value in cell A15. The value in C15 is "Fred". The word "Fred" should replace the "14" in cell G4.

	A	B	C	D	E	F	G	H	I	J	K	L
1	ID	Item	Value	Date	Product	Region	Salesperson	Customer	Price	Discount	Warranty	Distribution
2	1	Product 1	Red	140	3	7	17	35	49	60	64	66
3	2	Product 2	Green	135	4	6	15	30	54	57	62	66
4	3	Product 3	Yellow	123	3	6	14	30	52	57	61	65
5	4	Product 4	Blue	115	4	7	20	33	55	57	63	65
6	5	Region 1	North	84	4	6	13	30	53	60	64	66
7	6	Region 2	South	135	2	8	22	37	48	58	61	65
8	7	Region 3	East	151	2	6	14	31	48	58	61	66
9	8	Region 4	West	128	1	8	23	40	44	60	63	66
10	9	Person 1	Adam	126	3	7	18	35	50	60	64	65
11	10	Person 2	Bill	94	4	6	15	32	54	58	64	65
12	11	Person 3	Carl	131	3	7	19	34	51	57	63	66
13	12	Person 4	Dave	70	2	8	23	39	47	58	63	66
14	13	Person 5	Evan	82	2	6	16	31	48	57	64	65
15	14	Person 6	Fred	113	1	6	16	32	42	60	61	66
16	15	Person 7	Gary	77	2	6	14	29	48	58	63	66
17	16	Person 8	Hank	81	1	7	18	36	42	57	63	65
18	17	Person 9	Ivan	153	1	5	10	25	44	58	62	65
19	18	Person 10	John	111	3	6	16	31	52	57	64	66
20	19	Person 11	Kent	100	2	8	21	38	47	59	62	65
21	20	Person 12	Liam	82	4	5	11	25	56	57	62	65

<colgroup><col><col><col span="11"></colgroup><tbody>
</tbody>

Thanks for any help on this!

 

[PCL]

See how next code can help

Option Explicit


Sub ChangeData()
'
Dim DataDic   As Object
Set DataDic = CreateObject("Scripting.Dictionary")
Dim Rg  As Range
Dim Wkrg As Range


    For Each Rg In Range([A2], Cells(Rows.Count, 1).End(3))
        DataDic.Item(Rg.Value) = Rg(1, 3).Value
    Next Rg
    Set Wkrg = ActiveSheet.UsedRange
    Set Wkrg = Intersect(Wkrg, Wkrg.Offset(1, 3))
    For Each Rg In Wkrg
        With DataDic
            If (.exists(Rg.Value)) Then Rg = .Item(Rg.Value)
        End With
    Next Rg
End Sub

 

[ChristineJ]

It works wonderfully!

The only minor thing is that the last column I use is L, but it also fills in the word "Value" for all of the rows in column M. I can easily add code to delete column M after your code runs if there not a quick adjustment.

Thanks so much! This is not something I could even come close to doing myself. CJ

 

[PCL]

Here we are,

Option Explicit


Sub ChangeData()
'
Dim DataDic   As Object
Set DataDic = CreateObject("Scripting.Dictionary")
Dim Rg  As Range
Dim Wkrg As Range
Const ColLst = "D:L"
    For Each Rg In Range([A2], Cells(Rows.Count, 1).End(3))
        DataDic.Item(Rg.Value) = Rg(1, 3).Value
    Next Rg
    Set Wkrg = ActiveSheet.UsedRange
    Set Wkrg = Intersect(Wkrg, Columns(ColLst))
    Set Wkrg = Intersect(Wkrg, Wkrg.Offset(1, 0))
    Application.ScreenUpdating = False
    For Each Rg In Wkrg
        With DataDic
            If (.exists(Rg.Value)) Then Rg = .Item(Rg.Value)
        End With
    Next Rg
    Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

If all your columns have about 5000 rows, then this variation should be a bit quicker.

Sub MakeReplacements()
  Dim d As Object
  Dim a As Variant
  Dim i As Long, j As Long, ub2 As Long
  
  Set d = CreateObject("Scripting.dictionary")
  a = Range("A2:L" & Range("A" & Rows.Count).End(xlUp).Row).Value
  ub2 = UBound(a, 2)
  For i = 1 To UBound(a)
    d(a(i, 1)) = a(i, 3)
  Next i
  For i = 1 To UBound(a)
    For j = 4 To ub2
      If d.exists(a(i, j)) Then a(i, j) = d(a(i, j))
    Next j
  Next i
  Range("A2").Resize(UBound(a), ub2).Value = a
End Sub

 

[ChristineJ]

These solutions work perfectly! Thanks to you both.

 

[Peter_SSs]

These solutions work perfectly! Thanks to you both.

You are very welcome.

 

[PCL]

Good news, it was a great pleasure!