VLOOKUP or Macro?

S

Shwapx

New Member
Joined
Sep 28, 2022
Messages
48
Office Version
  1. 365
Platform
  1. Windows
Hello All,

I'm looking for opinion for certain task which I need to execute in this table. If you think that can be done with macro or formula. What would be the best possible way. Header2 and Header3 are on different sheet, but that can be adjusted.

Book1
ABCDEFG
1Header1Output which I'm looking forward after run a macro or formula in column A. Instead of CODE1, CODE2 or CODE3 print all the values in Header2 which are for that CODE and keep other recordsHeader2Header3
2XXXXXXXXTestCODE1
3XXXXXXXXTest1CODE1
4XXXXXXXXTest2CODE1
5CODE1TestTest3CODE1
6XXXXTest1Test4CODE1
7XXXXTest2Test21CODE2
8CODE2Test3Test22CODE2
9CODE3Test4Test33CODE3
10XXXXXXXXTest34CODE3
11XXXXXXXX
12Test21
13Test22
14Test33
15Test34
16XXXX
17XXXX
Sheet1
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
If you want the result in the same column A.
Try the following macro.
In the macro on the right side of the lines, I put a comment so that you can adjust the names of the sheets and columns where the information is located.

The data to adjust is highlighted in blue.

Rich (BB code): 
Sub Replace_Code()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant
  Dim c As Range, r As Range, f As Range, cell As String
  Dim i As Long, k As Long
  
  Set sh1 = Sheets("Sheet1")                                      'Fit sheet name with Header1
  Set sh2 = Sheets("Sheet2")                                      'Fit sheet name with Header2 and Header3
  Set r = sh2.Range("B1", sh2.Range("B" & Rows.Count).End(3))     'Column "B" with Header3
  
  a = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1) + r.Rows.Count, 1 To 1)
  For i = 1 To UBound(a, 1)
    
    Set f = r.Find(a(i, 1), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        k = k + 1
        b(k, 1) = sh2.Range("A" & f.Row).Value                    'Column "A" with Header2
        Set f = r.FindNext(f)
      Loop While f.Address <> cell
    Else
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
    
  Next
  sh1.Range("A2").Resize(UBound(b)).Value = b                     'The output starts in cell A2
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------
​
 
Upvote 1
DanteAmor said:
If you want the result in the same column A.
Try the following macro.
In the macro on the right side of the lines, I put a comment so that you can adjust the names of the sheets and columns where the information is located.

The data to adjust is highlighted in blue.

Rich (BB code): 
Sub Replace_Code()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant
  Dim c As Range, r As Range, f As Range, cell As String
  Dim i As Long, k As Long
 
  Set sh1 = Sheets("Sheet1")                                      'Fit sheet name with Header1
  Set sh2 = Sheets("Sheet2")                                      'Fit sheet name with Header2 and Header3
  Set r = sh2.Range("B1", sh2.Range("B" & Rows.Count).End(3))     'Column "B" with Header3
 
  a = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1) + r.Rows.Count, 1 To 1)
  For i = 1 To UBound(a, 1)
   
    Set f = r.Find(a(i, 1), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        k = k + 1
        b(k, 1) = sh2.Range("A" & f.Row).Value                    'Column "A" with Header2
        Set f = r.FindNext(f)
      Loop While f.Address <> cell
    Else
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
   
  Next
  sh1.Range("A2").Resize(UBound(b)).Value = b                     'The output starts in cell A2
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------
​
Click to expand...
On the example sheets it's working perfectly fine I will put that in the work file and let you know! Thanks.
 
Upvote 0
DanteAmor said:
If you want the result in the same column A.
Try the following macro.
In the macro on the right side of the lines, I put a comment so that you can adjust the names of the sheets and columns where the information is located.

The data to adjust is highlighted in blue.

Rich (BB code): 
Sub Replace_Code()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant
  Dim c As Range, r As Range, f As Range, cell As String
  Dim i As Long, k As Long
 
  Set sh1 = Sheets("Sheet1")                                      'Fit sheet name with Header1
  Set sh2 = Sheets("Sheet2")                                      'Fit sheet name with Header2 and Header3
  Set r = sh2.Range("B1", sh2.Range("B" & Rows.Count).End(3))     'Column "B" with Header3
 
  a = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1) + r.Rows.Count, 1 To 1)
  For i = 1 To UBound(a, 1)
   
    Set f = r.Find(a(i, 1), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        k = k + 1
        b(k, 1) = sh2.Range("A" & f.Row).Value                    'Column "A" with Header2
        Set f = r.FindNext(f)
      Loop While f.Address <> cell
    Else
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
   
  Next
  sh1.Range("A2").Resize(UBound(b)).Value = b                     'The output starts in cell A2
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------
​
Click to expand...
It's working, but I just remember I need to add one more set of data since my work data looks like that. So I have to add the information in Header1.1 as well. Since now when I run the macro this information is missing. And it's coming from Header4. Do you think that can be changed. Really thank you for the macro. So A and B need to look like column D in my example.

Code replacement.xlsx
ABCDEFGHI
1Header1Header1.1Output which I'm looking forward after run a macro or formula in column A and B. Instead of CODE1, CODE2 or CODE3 print all the values in Header2 which are for that CODE and keep other recordsHeader2Header3Header4
2XXXXXXXXXXXXXXXXTestCODE1Text1
3XXXXXXXXXXXXXXXXTest1CODE1Text1
4XXXXXXXXXXXXXXXXTest2CODE1Text1
5CODE1Text1TestText1Test3CODE1Text1
6XXXXXXXXTest1Text1Test4CODE1Text1
7XXXXXXXXTest2Text1Test21CODE2Text2
8CODE2Text2Test3Text1Test22CODE2Text2
9CODE3Text3Test4Text1Test33CODE3Text3
10XXXXXXXXXXXXXXXXTest34CODE3Text3
11XXXXXXXXXXXXXXXX
12Test21Text2
13Test22Text2
14Test33Text3
15Test34Text3
16XXXXXXXX
17XXXXXXXX
Sheet1
 
Upvote 0
I think I was able to modify it. Please let me know if it looks good.
Rich (BB code): 
Sub Replace_Code2()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant
  Dim c As Range, r As Range, f As Range, cell As String
  Dim i As Long, k As Long
 
  Set sh1 = Sheets("Sheet1")                                      'Fit sheet name with Header1
  Set sh2 = Sheets("Sheet2")                                      'Fit sheet name with Header2 and Header3
  Set r = sh2.Range("B1", sh2.Range("B" & Rows.Count).End(3))     'Column "B" with Header3
 
  a = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1) + r.Rows.Count, 1 To 2)
 
  For i = 1 To UBound(a, 1)
    Set f = r.Find(a(i, 1), , xlValues, xlWhole, , , False)
   
    If Not f Is Nothing Then
      cell = f.Address
      Do
        k = k + 1
        b(k, 1) = sh2.Range("A" & f.Row).Value                    'Column "A" with Header2
        b(k, 2) = sh2.Range("C" & f.Row).Value                    'Column "C" with Header4
        Set f = r.FindNext(f)
      Loop While f.Address <> cell
    Else
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = sh1.Range("B" & i + 1).Value                      'Column "B" with Header3 from Sheet1
    End If
  Next
 
  sh1.Range("A2").Resize(UBound(b), 2).Value = b                   'The output starts in cell A2
End Sub
 
Upvote 0
Hello @DanteAmor ,

I have one problem with this and it's that on first sheet I might have same CODE appear twice, but with different text in Header1.1 and then if I run the above macro it will replace the text in Header1.1 with the one from sheet3.

So I think if we can modify this to instead of copy the text from sheet3 from Header4 to copy the same text from Header1.1 for each replaced code.

So the data will look like this. Do you think you might help me with adjusting it.

Code replacement.xlsx
ABCDEFGH
1Header1Header1.1Output which I'm looking forward after run a macro or formula in column A and B. Instead of CODE1, CODE2 or CODE3 print all the values in Header2 which are for that CODE and keep other records and copy for each new record the text from Header1.1Header2Header3
2XXXXXXXXXXXXXXXXTestCODE1
3XXXXXXXXXXXXXXXXTest1CODE1
4XXXXXXXXXXXXXXXXTest2CODE1
5CODE1Text1TestText1Test3CODE1
6CODE1Text11Test1Text1Test4CODE1
7XXXXXXXXTest2Text1Test21CODE2
8CODE2Text2Test3Text1Test22CODE2
9CODE3Text3Test4Text1Test33CODE3
10XXXXXXXXTestText11Test34CODE3
11XXXXXXXXTest1Text11
12Test2Text11
13Test3Text11
14Test4Text11
15XXXXXXXX
16XXXXXXXX
17Test21Text2
18Test22Text2
19Test33Text3
20Test34Text3
21XXXXXXXX
22XXXXXXXX
Sheet1
 
Upvote 0
You did pretty well and are very close. Try this.
The changes I made have XXX in the comment.

VBA Code: 
Sub Replace_Code3()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant
  Dim c As Range, r As Range, f As Range, cell As String
  Dim i As Long, k As Long
 
  Set sh1 = Sheets("Sheet1")                                      'Fit sheet name with Header1
  Set sh2 = Sheets("Sheet2")                                      'Fit sheet name with Header2 and Header3
  Set r = sh2.Range("B1", sh2.Range("B" & Rows.Count).End(3))     'Column "B" with Header3
 
  a = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(3).Offset(, 1)).Value ' XXX Expanded array to include both columns
  ReDim b(1 To UBound(a, 1) + r.Rows.Count, 1 To 2)
 
  For i = 1 To UBound(a, 1)
    Set f = r.Find(a(i, 1), , xlValues, xlWhole, , , False)
  
    If Not f Is Nothing Then
      cell = f.Address
      Do
        k = k + 1
        b(k, 1) = sh2.Range("A" & f.Row).Value                    'Column "A" with Header2
        b(k, 2) = a(i, 2)                                         'XXX Column B from original data Header1.1
        Set f = r.FindNext(f)
      Loop While f.Address <> cell
    Else
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)                                              'XXX Column B from original data Header1.1
    End If
   
  Next
 
  sh1.Range("A2").Resize(k, 2).Value = b                            'The output starts in cell A2 XXX used k instead of Ubound
End Sub
 
Upvote 1
Alex Blakenburg said:
You did pretty well and are very close. Try this.
The changes I made have XXX in the comment.

VBA Code: 
Sub Replace_Code3()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant
  Dim c As Range, r As Range, f As Range, cell As String
  Dim i As Long, k As Long
 
  Set sh1 = Sheets("Sheet1")                                      'Fit sheet name with Header1
  Set sh2 = Sheets("Sheet2")                                      'Fit sheet name with Header2 and Header3
  Set r = sh2.Range("B1", sh2.Range("B" & Rows.Count).End(3))     'Column "B" with Header3
 
  a = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(3).Offset(, 1)).Value ' XXX Expanded array to include both columns
  ReDim b(1 To UBound(a, 1) + r.Rows.Count, 1 To 2)
 
  For i = 1 To UBound(a, 1)
    Set f = r.Find(a(i, 1), , xlValues, xlWhole, , , False)
 
    If Not f Is Nothing Then
      cell = f.Address
      Do
        k = k + 1
        b(k, 1) = sh2.Range("A" & f.Row).Value                    'Column "A" with Header2
        b(k, 2) = a(i, 2)                                         'XXX Column B from original data Header1.1
        Set f = r.FindNext(f)
      Loop While f.Address <> cell
    Else
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)                                              'XXX Column B from original data Header1.1
    End If
  
  Next
 
  sh1.Range("A2").Resize(k, 2).Value = b                            'The output starts in cell A2 XXX used k instead of Ubound
End Sub
Click to expand...
Thank you it's working perfect. Thanks as well to @DanteAmor. I can't mark both as solutions, but both works for what was asked. Thank you guys. This fix the issue if I have the same code, but different text next to it. The previous one which I have modified based on Dante macro was working with another column, but then I had a case where a same code have different text which it was going to be an issue so this fixed it!
 
Upvote 0
Shwapx said:
Hello @DanteAmor ,

I have one problem with this and it's that on first sheet I might have same CODE appear twice, but with different text in Header1.1 and then if I run the above macro it will replace the text in Header1.1 with the one from sheet3.

So I think if we can modify this to instead of copy the text from sheet3 from Header4 to copy the same text from Header1.1 for each replaced code.

So the data will look like this. Do you think you might help me with adjusting it.
Click to expand...

Of course, here is my adjusted macro. I added comments on the right with the modified lines.

VBA Code: 
Sub Replace_Code_v2()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant
  Dim c As Range, r As Range, f As Range, cell As String
  Dim i As Long, k As Long
  
  Set sh1 = Sheets("Sheet1")                                            'Fit sheet name with Header1
  Set sh2 = Sheets("Sheet2")                                            'Fit sheet name with Header2 and Header3
  Set r = sh2.Range("B1", sh2.Range("B" & Rows.Count).End(3))           'Column "B" with Header3
  
  a = sh1.Range("A2:B" & sh1.Range("A" & Rows.Count).End(3).Row).Value  'Columns A and B
  ReDim b(1 To UBound(a, 1) + r.Rows.Count, 1 To 2)                     'Resize to 2 columns
  For i = 1 To UBound(a, 1)
    
    Set f = r.Find(a(i, 1), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        k = k + 1
        b(k, 1) = sh2.Range("A" & f.Row).Value                          'Column "A" with Header2
        b(k, 2) = a(i, 2)                                               'take the Header1.1 (column B)
        Set f = r.FindNext(f)
      Loop While f.Address <> cell
    Else
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)                                                 'take the Header1.1 (column B)
    End If
    
  Next
  sh1.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b          'The output starts in cell A2, And with resize to 2 columns
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 1
Solution
You must log in or register to reply here.

Similar threads

T
  • Question Question
VBA Stuck Sanitising Several Sheets
Replies
2
Views
187
Tarkemelion
T
J
  • Question Question
Vlookup into next blank column
Replies
4
Views
345
Vogateer
V
Q
  • Question Question
Macro needed to insert 4 rows in table, copy data from above, copy data from another sheet and paste special (transpose values) to those new rows...re
Replies
1
Views
228
sijpie
sijpie
M
  • Solved
How to move custom VBA/ribbons
2
Replies
12
Views
490
missingsc
M
A
  • Question Question
VBA for setting up the printing pages per sheet
Replies
0
Views
421
Aurum1
A

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top