Need VBA Code to "VLOOKUP" but keep source cell Formatting

Try this. This will copy the format that corresponds to the lookup value and paste the format to Sheet 1

Sub test()

Dim rCell As Range
Dim x As Integer

'First use a vlookup to pull in the color of each animal
For Each rCell In Range("a2", Range("a2").End(xlDown))
rCell.Offset(0, 1).Formula = "=vlookup(" & rCell.Address(0, 1) & ",Sheet2!$A$2:$B$5,2,false)"

'Then find the format of the color on Sheet 2 and copy it.
Sheets("sheet2").Activate
x = WorksheetFunction.Match(rCell.Value, Range("a1", Range("a1").End(xlDown)), False)
Cells(x, 2).Select
Selection.Copy

'Then paste the format to the adjacent cell the loop is running for
Sheets("sheet1").Select
rCell.Select
rCell.Offset(0, 1).Select
    With Selection
        .PasteSpecial xlPasteFormats
    End With



Next rCell





End Sub

Originally Posted by jkj115

Try this. This will copy the format that corresponds to the lookup value and paste the format to Sheet 1

Sub test()

Dim rCell As Range
Dim x As Integer

'First use a vlookup to pull in the color of each animal
For Each rCell In Range("a2", Range("a2").End(xlDown))
rCell.Offset(0, 1).Formula = "=vlookup(" & rCell.Address(0, 1) & ",Sheet2!$A$2:$B$5,2,false)"

'Then find the format of the color on Sheet 2 and copy it.
Sheets("sheet2").Activate
x = WorksheetFunction.Match(rCell.Value, Range("a1", Range("a1").End(xlDown)), False)
Cells(x, 2).Select
Selection.Copy

'Then paste the format to the adjacent cell the loop is running for
Sheets("sheet1").Select
rCell.Select
rCell.Offset(0, 1).Select
    With Selection
        .PasteSpecial xlPasteFormats
    End With



Next rCell





End Sub

I got an error message when try your code:
"Run-time error '1004'"
Select method of Range class failed"

Regards,
tt3

On what line of the code (go to VBA and hit f8 to click through the code step by step)? What are the names of your sheets

Hi jkj115,

The error is at below line and the names are Sheet1 and Sheet2

Cells(x, 2).Select

Regards,
tt3

Try

Sub test()
    Dim r As Range
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each r In Sheets("sheet2").Cells(1).CurrentRegion.Columns(1).Cells
            Set .Item(r.Value) = r(, 2)
        Next
        For Each r In Sheets("sheet1").Cells(1).CurrentRegion.Columns(1).Cells
            If .exists(r.Value) Then .Item(r.Value).Copy r(, 2)
        Next
    End With
End Sub

Originally Posted by jindon

Try

Sub test()
    Dim r As Range
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each r In Sheets("sheet2").Cells(1).CurrentRegion.Columns(1).Cells
            Set .Item(r.Value) = r(, 2)
        Next
        For Each r In Sheets("sheet1").Cells(1).CurrentRegion.Columns(1).Cells
            If .exists(r.Value) Then .Item(r.Value).Copy r(, 2)
        Next
    End With
End Sub

Hi jindon,
Your code is perfect and thank you for your help.

Regards,
tt3

This works PERFECTLY. Thank you so much jindon; you don't know how much time you just saved me!!!