• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Compare cell value in two workbook and copy value from 5 columns to first WB when match

Pioneer

New Member
Hello,

Need help!!.. do we have a macros for :
I have two workbook - WB 1 and WB 2
I am looking to compare cells $A:$A from WB1 with cells $A:$A in WB2. Suppose the value in WB2 cell A6 matches with WB1 A1, I want the value from WB2 cell I6, J6, K6, L6 amd M6 copied over to WB1 cell Q1, R1, S1, T1 and U1 respectively. i.e.
WB2 I6 --> WB1 Q1,
WB2 J6 --> WB1 R1
WB2 K6 --> WB1 S1
WB2 L6 --> WB1 T3
WB2 M6 --> WB1 U1

At a clink of a button, I require that all cells from WB1 $A:$A should automatically compare the value in WB2 $A:$A, and if the value matches, update columns Q,R,S,T and U in WB1 with corrosponding value in column I, J, K, L and M in WB2.

I have 250 such cells in WB1 to compare with WB2 everyday.

I have attached a sample file.

I greatly appreciate your help!
 

Attachments

  • WB1.chandoo.xls
    34 KB · Views: 1
  • WB2.chandoo.xls
    35.5 KB · Views: 1
Last edited:

Hi,

both workbooks opened, must paste this code to WB1 :​
Code:
Sub Demo1()
    Const WBK = "WB2.chandoo.xls", WSH = "Sheet1"
    If Evaluate("ISREF('[" & WBK & "]" & WSH & "'!A1)") = False Then Beep: Exit Sub
  
    With Workbooks(WBK).Worksheets(WSH).Cells(1).CurrentRegion
        AD1$ = .Columns(1).Address(, , , True)
        AD2$ = .Address(, , , True)
    End With
  
    With Sheet1
        R& = .Cells(1).CurrentRegion.Rows.Count - 1:  If R = 0 Then Exit Sub
        Application.ScreenUpdating = False
           .[W2].Resize(R).Formula = "=MATCH(A2," & AD1 & ",0)"
        With .[Q2:U2].Resize(R)
            .Formula = "=IF(ISNUMBER($W2),INDEX(" & AD2 & ",$W2,COLUMN()-8),"""")"
            .Formula = .Value
        End With
           .[W2].Resize(R).Clear
    End With
End Sub
Do you like it ? So thanks to click on bottom right Like !
 
Thank you for a prompt reply.
I am getting a debug error at:
R& = .Cells(1).CurrentRegion.Rows.Count - 1

To make it easy, i can copy the sheet from WB2 to WB1 (sheet 1) so we have to deal with only one WB.

As you suggested i have opened only 2 WB open, but getting an error when i run the macros.

Code:
Sub Demo1()
    Const WBK = "WB2.chandoo.xls", WSH = "Sheet1"
    If Evaluate("ISREF('[" & WBK & "]" & WSH & "'!A1)") = False Then Beep: Exit Sub
   
    With Workbooks(WBK).Worksheets(WSH).Cells(1).CurrentRegion
        AD1$ = .Columns(1).Address(, , , True)
        AD2$ = .Address(, , , True)
    End With
   
    With Feuil1
        R& = .Cells(1).CurrentRegion.Rows.Count - 1:  If R = 0 Then Exit Sub
        Application.ScreenUpdating = False
           .[W2].Resize(R).Formula = "=MATCH(A2," & AD1 & ",0)"
        With .[Q2:U2].Resize(R)
            .Formula = "=IF(ISNUMBER($W2),INDEX(" & AD2 & ",$W2,COLUMN()-8),"""")"
            .Formula = .Value
        End With
           .[W2].Resize(R).Clear
    End With
End Sub
 

It seems you paste from mail but code was already updated in post #2 :

replace With Feuil1 by With Sheet1 in codeline #10 …
 
It seems you paste from mail but code was already updated in post #2 :

replace With Feuil1 by With Sheet1 in codeline #10 …
Thank you, so much.

It works.

I just realized, i will have multiple WB's open while working on this.
Can i copy WB2 sheet 1 to WB1 sheet 2 and run the macros.

Also in near future, I will have to copy cells value from WB2 Q:U to WB1 Q:U instead of current Wb2 I:M to Wb1 Q:U
 

No issue with many opened workbooks 'cause Demo1 works with name …

With worksheets in same workbook :​
Code:
Sub Demo2()
    With Sheet2.Cells(1).CurrentRegion
        AD1$ = .Columns(1).Address(, , , True)
        AD2$ = .Address(, , , True)
    End With
 
    With Sheet1
        R& = .Cells(1).CurrentRegion.Rows.Count - 1:  If R = 0 Then Exit Sub
             Application.ScreenUpdating = False
                .[W2].Resize(R).Formula = "=MATCH(A2," & AD1 & ",0)"
        With .[Q2:U2].Resize(R)
             .Formula = "=IF(ISNUMBER($W2),INDEX(" & AD2 & ",$W2,COLUMN()-8),"""")"
             .Formula = .Value
        End With
                .[W2].Resize(R).Clear
    End With
End Sub
And to copy same columns (Q → Q) just remove -8 in codeline #12 formula.
 
No issue with many opened workbooks 'cause Demo1 works with name …

With worksheets in same workbook :​
Code:
Sub Demo2()
    With Sheet2.Cells(1).CurrentRegion
        AD1$ = .Columns(1).Address(, , , True)
        AD2$ = .Address(, , , True)
    End With

    With Sheet1
        R& = .Cells(1).CurrentRegion.Rows.Count - 1:  If R = 0 Then Exit Sub
             Application.ScreenUpdating = False
                .[W2].Resize(R).Formula = "=MATCH(A2," & AD1 & ",0)"
        With .[Q2:U2].Resize(R)
             .Formula = "=IF(ISNUMBER($W2),INDEX(" & AD2 & ",$W2,COLUMN()-8),"""")"
             .Formula = .Value
        End With
                .[W2].Resize(R).Clear
    End With
End Sub
And to copy same columns (Q → Q) just remove -8 in codeline #12 formula.
Thanks,
The macros runs when i am copying from I --> Q, but does not runs for Q--> Q. As you mentioned, I have deleted -8 from codeline.
 

I amend Sheet2 to same Sheet1 columns design
(data in Q to U, no blank column, a continous data block)
and remove couple of chars as written : my code works like a breeze ! :cool:
 
Last edited:
I amend Sheet2 to same Sheet1 columns design
(data in Q to U, no blank column, a continous data block)
and remove couple of chars as written : my code works like a breeze ! :cool:

Thanks.
One small change, instead of copying 5 columns, I have 7 columns, i.e. Q:W --> Q:W.
Also, I am getting 0 when the cell is blank.
WIll it possible to get a blank when its blank and N/A when its a no match.

(Opps .. another addition.. Can i get the same format. say if i have a cell filled Red, i would like to copy the same in Sheet 1.)
Thank you soo much for all your help.
 

On my side with a blank source cell, destination cell is blank too, no 0 !

Fore more columns, just amend adresses in code …

'Cause of your new color addition, my actual code goes to trash bin ‼
Can't use anymore Excel formula, so future code should be slower
in case of numerous data lines … It's worse not to explain all needs !

Fisrt think about all yours needs, then detail them in your next post
with a new workbook (xlsx no code) attached with both worksheets
to get a last code …​
 
Last edited:
On my side with a blank source cell, destination cell is blank too, no 0 !

Fore more columns, just amend adresses in code …

'Cause of your new color addition, my actual code goes to trash bin ‼
Can't use anymore Excel formula, so future code should be slower
in case of numerous data lines … It's worse not to explain all needs !

Fisrt think about all yours needs, then detail them in your next post
with a new workbook (xlsx no code) attached with both worksheets
to get a last code …​
I am using the following code and is getting 0 for all calls Q to W when i change [Q2:U2] to [Q2:W2]. Also i get 0 for all blank cells.

Code:
Sub Update()
    With Sheet2.Cells(1).CurrentRegion
        AD1$ = .Columns(1).Address(, , , True)
        AD2$ = .Address(, , , True)
    End With

    With Sheet1
        R& = .Cells(1).CurrentRegion.Rows.Count - 1:  If R = 0 Then Exit Sub
             Application.ScreenUpdating = False
                .[W2].Resize(R).Formula = "=MATCH(A2," & AD1 & ",0)"
        With .[Q2:W2].Resize(R)
             .Formula = "=IF(ISNUMBER($W2),INDEX(" & AD2 & ",$W2,COLUMN()-8),"""")"
             .Formula = .Value
        End With
                .[W2].Resize(R).Clear
    End With
End Sub
 
@Marc L

I think @Pioneer need to comment this line.

Code:
.[W2].Resize(R).Clear

@ Deepak and @Marc L

I haev attached the workbook.

When member ID match on sheet 1 and sheet 2, i want Sheet 2 column I: O copied Over to sheet 1 column Q:W.

From next week, I will need sheet 2 column Q:W copied ovet to sheet 1 column Q:W, when the member ID matches.
 

Attachments

  • Workbook.xlsm
    39.8 KB · Views: 3
Last edited:
When an ID matches, this new demonstration copies
Sheet2 last 7 columns to Sheet1 last 7 columns :​
Code:
Sub Demo3()
Const L = 7
Dim Rf As Range, Rg As Range
Application.ScreenUpdating = False

With Sheet2.Cells(1).CurrentRegion.Columns
   Set Rg = .Item(1):  F& = .Count - L + 1
End With

With Sheet1.Cells(1).CurrentRegion
        C& = .Columns.Count - L + 1
    For R& = 2 To .Rows.Count
        Set Rf = Rg.Find(.Cells(R, 1).Value, , xlValues, xlWhole)
        If Not Rf Is Nothing Then Rf(1, F).Resize(, L).Copy .Cells(R, C)
    Next
End With
           Set Rf = Nothing:  Set Rg = Nothing
End Sub
You like ? So thanks again to …​
 
Last edited:
When an ID matches, this new demonstration copies
Sheet2 last 7 columns to Sheet1 last 7 columns :​
Code:
Sub Demo3()
Const L = 7
Dim Rf As Range, Rg As Range
Application.ScreenUpdating = False

With Sheet2.Cells(1).CurrentRegion.Columns
   Set Rg = .Item(1):  F& = .Count - L + 1
End With

With Sheet1.Cells(1).CurrentRegion
        C& = .Columns.Count - L + 1
    For R& = 2 To .Rows.Count
        Set Rf = Rg.Find(.Cells(R, 1).Value, , xlValues, xlWhole)
        If Not Rf Is Nothing Then Rf(1, F).Resize(, L).Copy .Cells(R, C)
    Next
End With
           Set Rf = Nothing:  Set Rg = Nothing
End Sub
You like ? So thanks again to …​
@Marc L Thank you so much !!!
 
When an ID matches, this new demonstration copies
Sheet2 last 7 columns to Sheet1 last 7 columns :​
Code:
Sub Demo3()
Const L = 7
Dim Rf As Range, Rg As Range
Application.ScreenUpdating = False

With Sheet2.Cells(1).CurrentRegion.Columns
   Set Rg = .Item(1):  F& = .Count - L + 1
End With

With Sheet1.Cells(1).CurrentRegion
        C& = .Columns.Count - L + 1
    For R& = 2 To .Rows.Count
        Set Rf = Rg.Find(.Cells(R, 1).Value, , xlValues, xlWhole)
        If Not Rf Is Nothing Then Rf(1, F).Resize(, L).Copy .Cells(R, C)
    Next
End With
           Set Rf = Nothing:  Set Rg = Nothing
End Sub
You like ? So thanks again to …​
Sorry... I got so excited about the new code that i forgot to test it.

I was using it today and found that its not working as intended.
nothing happens after i run the macros.

@Deepak and @Marc L : FYI.. you guys helped me in deciding to sign up for the training course.
 

Test it with post #14 workbook, well works on my side …
@Marc L and @Deepak

Please pardon me for for getting this old post back to life.
@Marc L, your macros is really helping me a lot.

I have added new columns and the i need the macros to work would require some updates. Can you help me out with the new request.

Instead of mapping and copping sheet 2 last 7 columns to sheet 1, i would love to have:

  • Map the member ID from sheet 1 column A (S1C1) to sheet 2 column A (S2CA) (If possible, i need a macros to be flexible if the mapping column changes i.e. instead to S1CA --> S2CA, i may require S1CA --> S2CD - sheet 2 column D)
  • Once a common member ID is identified between the two sheets (lets say e.g. member 961 is located on both sheets), i need to update information for member 961 from sheet 2 to sheet 1. This time instead of copying last 7 columns from sheet 2 to sheet 1, i need to copy only specific columns from sheet 2 to sheet 1.
    • e.g.
    • upload_2015-7-15_21-45-55.png
 

Attachments

  • Workbook 2.xlsm
    35.6 KB · Views: 0

Hi !

A parameter worksheet as Sheet3 is the best for flexibility !
You specified M column copy with formatting but actually all columns
are copied with formatting : no matter that's for all ?

For flexibility as well, if member ID title column could change,
title columns worksheets must be set to Sheet3 …
If title column never change, always "member ID", never mind,
code will scan its position in each worksheet row #1 …
 

Notice actually in last attached workbook titles are different
between worksheets ! Maybe a typo in Sheet2 ?
 
If a new column is inserted in one of both first worksheets,
so your Sheet3 parameters table is not very flexible !

So better is to work with real columns titles, amend Sheet3 like this :
• starts in column #1, row #1.
• A column is the source worksheet, B column is the destination worksheet.
• Row #1 is the worksheet exact name. "sheet 2" is not "Sheet2" !
• Row #2 is the matching column ID.
• When destination worksheet has same column title, leave B column empty.
• From row #3 are the data columns titles to copy.

With a well worsheet design, it should be enough but it's not the case here
with duplicates columns titles ! (Status)
Match Excel function returns first found search data position :
no matter when it's the case but it's not yours !

Adding special rule in duplicate search and not first :
• instead of column title, enter column number (not letter).
Less flexible but no choice with that duplicate design !

According to all previous points :​
Code:
Sub Demo4()
Dim COL(1 To 3)
    COL(3) = Sheet3.Cells(1).CurrentRegion.Value

For C& = 2 To 1 Step -1
    If Not Evaluate("ISREF('" & COL(3)(1, C) & "'!A1)") Then MsgBox "Not found", vbExclamation, COL(3)(1, C): Exit Sub
    With Worksheets(COL(3)(1, C)).Cells(1).CurrentRegion
        For R& = 2 To UBound(COL(3))
            If COL(3)(R, C) = "" Or Not IsNumeric(COL(3)(R, C)) Then
                S$ = IIf(COL(3)(R, C) = "", COL(3)(R, 1), COL(3)(R, C))
                 V = Application.Match(S, .Rows(1), 0)
                If IsNumeric(V) Then COL(3)(R, C) = V Else MsgBox "Column « " & S & " » not found", vbExclamation, COL(3)(1, C): Exit Sub
            End If
        Next
               COL(C) = .Columns(COL(3)(2, C)).Value
    End With
Next
                                Application.ScreenUpdating = False
For R = 2 To UBound(COL(2))
                 V = Application.Match(COL(2)(R, 1), COL(1), 0)
    If IsNumeric(V) Then
        For C = 3 To UBound(COL(3))
            Worksheets(COL(3)(1, 1)).Cells(V, COL(3)(C, 1)).Copy Worksheets(COL(3)(1, 2)).Cells(R, COL(3)(C, 2))
        Next
    End If
Next
End Sub
You should Like it !
 
If a new column is inserted in one of both first worksheets,
so your Sheet3 parameters table is not very flexible !

So better is to work with real columns titles, amend Sheet3 like this :
• starts in column #1, row #1.
• A column is the source worksheet, B column is the destination worksheet.
• Row #1 is the worksheet exact name. "sheet 2" is not "Sheet2" !
• Row #2 is the matching column ID.
• When destination worksheet has same column title, leave B column empty.
• From row #3 are the data columns titles to copy.

With a well worsheet design, it should be enough but it's not the case here
with duplicates columns titles ! (Status)
Match Excel function returns first found search data position :
no matter when it's the case but it's not yours !

Adding special rule in duplicate search and not first :
• instead of column title, enter column number (not letter).
Less flexible but no choice with that duplicate design !

According to all previous points :​
Code:
Sub Demo4()
Dim COL(1 To 3)
    COL(3) = Sheet3.Cells(1).CurrentRegion.Value

For C& = 2 To 1 Step -1
    If Not Evaluate("ISREF('" & COL(3)(1, C) & "'!A1)") Then MsgBox "Not found", vbExclamation, COL(3)(1, C): Exit Sub
    With Worksheets(COL(3)(1, C)).Cells(1).CurrentRegion
        For R& = 2 To UBound(COL(3))
            If COL(3)(R, C) = "" Or Not IsNumeric(COL(3)(R, C)) Then
                S$ = IIf(COL(3)(R, C) = "", COL(3)(R, 1), COL(3)(R, C))
                 V = Application.Match(S, .Rows(1), 0)
                If IsNumeric(V) Then COL(3)(R, C) = V Else MsgBox "Column « " & S & " » not found", vbExclamation, COL(3)(1, C): Exit Sub
            End If
        Next
               COL(C) = .Columns(COL(3)(2, C)).Value
    End With
Next
                                Application.ScreenUpdating = False
For R = 2 To UBound(COL(2))
                 V = Application.Match(COL(2)(R, 1), COL(1), 0)
    If IsNumeric(V) Then
        For C = 3 To UBound(COL(3))
            Worksheets(COL(3)(1, 1)).Cells(V, COL(3)(C, 1)).Copy Worksheets(COL(3)(1, 2)).Cells(R, COL(3)(C, 2))
        Next
    End If
Next
End Sub
You should Like it !
Thank you.
The column names will be different in sheet1 and sheet2. I must add, new columns will not be added in Sheet2!. the position is mapping will be fixed once identified i.e. Sheet 2 column E will always update sheet 1 column D.
 
According to Demo4, Sheet3 should look like this :

Sheet3.jpg

When B column blank, same value than A column …

Row #7 : Sheet2.Columns(13) - aka M - always
. updates Sheet1.Columns(21) - aka U

For true flexibility, if one Status column title is renamed in each worksheet,
example first one with a space leading, A7 cell will be Status and B7 empty …
 
Back
Top