VBA to find match of cell value on two different Spreadsheet and then copy adjacent cell (value and format)

lpchretien

New Member
Joined
Jun 17, 2023
Messages
1
Office Version
  1. 2019
Platform
  1. Windows
Hello,

I have two spreadsheets named New.xlsx and Old.xlsx. I'm looking for a VBA code that compare each column T values (unique ID) in New.xlsx with values in column T (unique ID) in Old.xlsx. When there is a match, it then copy the value and cell format (e.g. cell color) of the cell in column A of the Old.xlsx to the cell in column A in New.xlsx.

I found out this thread (VBA To find match of cell value and copy adjacent cell when match found) which work fine with 2 different Sheets in the same Excel document and to copy only cell value, but I have some difficulty to use it with 2 differents Excel files and to copy cell format.

Thanks for your help
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Re: "two spreadsheets named New.xlsx and Old.xlsx"
I assume you mean 2 workbooks? Or not?
Are both workbooks open when you run the macro?
Which workbook should have the macro as you have both workbooks as non macro workbooks (.xlsx)
Macro enabled workbooks have an .xlsm extension
What are the Sheet Names where you copy from and paste into?
 
Last edited:
Upvote 0
Try this (Both Workbooks to be open).
Change wb1, wb2, sh1 and sh2 to meaningful names for you
Code:
Sub Copy_Between_Workbooks()
Dim wb1 As Workbook, wb2 As Workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Dim c As Range
Set wb1 = ThisWorkbook    '<----- Workbook with the macro in it and where you paste into
Set wb2 = Workbooks("The Other Workbook Name.xlsx")    '<----- Change as required. Workbook where you copy from
Set sh1 = wb1.Worksheets("Sheet1")    '<----- Change as required
Set sh2 = wb2.Worksheets("Sheet1")    '<----- Change as required
    For Each c In sh1.Range("T2:T" & sh1.Cells(Rows.Count, 20).End(xlUp).Row)
        If Not IsError(Application.Match(c.Value, sh2.Columns(20), 0)) Then
            sh2.Columns(20).Find(c.Value, , , 1).Offset(, -19).Copy c.Offset(, -19)
        End If
    Next c
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,885
Messages
6,175,187
Members
452,616
Latest member
intern444

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