VBA/Macro to replace cell values using a lookup table within a 2nd sheet

robospike · Mar 24, 2016

Hi All,

I currently use a VLOOKUP function to merge details from one sheet into another, basicly I have a lookup table in the second sheet.

The formula is like this but I have to copy it down and use several columns:

Code:

  =IFERROR(VLOOKUP(A2,Sheet2DB!$A$2:$C$50000,2,FALSE),(F2))

What I need to do is replicate this within a VBA macro to help automate the process, however I am rather stuck.

Both sheets have a header row, the macro needs to process any row with a value in column A in the active sheet (Sheet1Data) and check for a matching record in the lookup table in Sheet2DB.

Eg when processing the first record in A2, where Sheet1Data A2 matches Sheet2DB A:A (any row in this sheet) then:

Sheet1Data E2 needs to equal Sheet2DB B2

and

Sheet1Data F2 needs to equal Sheet2DB C2

Where Sheet1Data A2 does not find a matching row within Sheet2DB A:A then:

Sheet1Data E2 and F2 should remain at their current value but a X character needs to be placed within P2.


Each row in the active sheet with a value in A needs to be processed with the exception of the header row.

Can anyone help me?

JackDanIce · Mar 24, 2016

Try:

Code:

Sub M1()

    Dim rng         As Range
    Dim arrTemp()   As Variant
    Dim x           As Long

    Application.ScreenUpdating = False
    
    With Sheets("Sheet2DB")
        x = .Cells(.rows.count, 1).End(xlUp).row
        Set rng = .Cells(2, 1).Resize(x - 1, 3)
    End With
    
    With Sheets("Sheet1Data")
        For x = 2 To .Cells(.rows.count, 1).End(xlUp).row
            With .Cells(x, 5).Resize(, 2)
                arrTemp = .value
                .ClearContents
            End With
            
            On Error Resume Next
            .Cells(x, 5) = rng.find(.Cells(x, 1).value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 1).value
            .Cells(x, 6) = rng.find(.Cells(x, 1).value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 2).value
            On Error GoTo 0
            
            If LenB(.Cells(x, 5)) = 0 Then
                .Cells(x, 5).Resize(, 2) = arrTemp
                .Range("P" & x).value = "X"
            End If
            Erase arrTemp
        Next x
    End With
    
    Application.ScreenUpdating = True
    
    Set rng = Nothing
    
End Sub

robospike · Mar 24, 2016

Hi, thanks so much for this.

I am just doing some tests now and it looks to be doing what I need, which is brill.

Would it be possible in the event of a non match in the lookup table to also copy A E and F from the data sheet and insert them below the last used row in the Sheet2DB sheet? If so, could it also adjust the formatting? Eg: make E and F in sheet1 and A B and C in sheet 2 red text as they are written? That way non matching entries are identifiable and can be edited within the lookup table.

I hope this makes sense?

JackDanIce · Mar 24, 2016

You're welcome. Again a guess, so test on a copy of your file or at least back it up prior to running code:

Code:

Sub M1()

    Dim rng         As Range
    Dim rng2        As Range
    Dim wsData      As Worksheet
    Dim arrTemp()   As Variant
    Dim x           As Long
    Dim i           As Long
        
    Set wsData = Sheets("Sheet1Data")
        
    Application.ScreenUpdating = False
    
    With Sheets("Sheet2DB")
        x = .Cells(.rows.count, 1).End(xlUp).row
        Set rng = .Cells(2, 1).Resize(x - 1, 3)
        Set rng2 = .Cells(x + 1, 1)
    End With
    
    With wsData
        For x = 2 To .Cells(.rows.count, 1).End(xlUp).row
            With .Cells(x, 5).Resize(, 2)
                arrTemp = .value
                .ClearContents
            End With
            
            On Error Resume Next
            .Cells(x, 5) = rng.find(.Cells(x, 1).value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 1).value
            .Cells(x, 6) = rng.find(.Cells(x, 1).value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 2).value
            On Error GoTo 0
            
            If LenB(.Cells(x, 5)) = 0 Then
                With .Cells(x, 5).Resize(, 2)
                    .value = arrTemp
                    .Font.Color = RGB(255, 0, 0)
                End With
                .Range("P" & x).value = "X"
                
                With rng2
                    .value = wsData.Cells(x, 1).value
                    .Offset(, 1).Resize(, 2).value = arrTemp
                    .Resize(, 3).Font.Color = RGB(255, 0, 0)
                End With
                Set rng2 = rng2.Offset(1)
                
                Erase arrTemp
                
            End If
            
        Next x
    End With
    
    Application.ScreenUpdating = True
    
    Set rng = Nothing
    Set rng2 = Nothing
    Set wsData = Nothing
    
End Sub

robospike · Mar 24, 2016

Thanks for this, Its looking really good. I am so greatful. I am just doing some testing with this, the only issue I can see currently.

If the macro is run once, all is well, if I change a red entry to black and change the text in the DB sheet, then run the macro again, the new text comes through but not the font color, it stays red rather than changing back to black. Any ideas?

JackDanIce · Mar 25, 2016

That's because it's replacing cell values, not copying the formatting. I'm resetting everything to general in this code:

Code:

Sub M1()

    Dim rng         As Range
    Dim rng2        As Range
    Dim wsData      As Worksheet
    Dim arrTemp()   As Variant
    Dim x           As Long
    Dim i           As Long
        
    Set wsData = Sheets("Sheet1Data")
        
    Application.ScreenUpdating = False
    
    With Sheets("Sheet2DB")
        x = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rng = .Cells(2, 1).Resize(x - 1, 3)
        Set rng2 = .Cells(x + 1, 1)
       .Cells.Font.Color = xlGeneral
    End With
    
    With wsData
        For x = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            With .Cells(x, 5).Resize(, 2)
                arrTemp = .Value
                .ClearContents
                .Font.Color = xlGeneral
            End With
            
            On Error Resume Next
            .Cells(x, 5) = rng.Find(.Cells(x, 1).Value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 1).Value
            .Cells(x, 6) = rng.Find(.Cells(x, 1).Value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 2).Value
            On Error GoTo 0
            
            If LenB(.Cells(x, 5)) = 0 Then
                With .Cells(x, 5).Resize(, 2)
                    .Value = arrTemp
                    .Font.Color = RGB(255, 0, 0)
                End With
                .Range("P" & x).Value = "X"
                
                With rng2
                    .Value = wsData.Cells(x, 1).Value
                    .Offset(, 1).Resize(, 2).Value = arrTemp
                    .Resize(, 3).Font.Color = RGB(255, 0, 0)
                End With
                Set rng2 = rng2.Offset(1)
                
                Erase arrTemp
                
            End If
            
        Next x
    End With
    
    Application.ScreenUpdating = True
    
    Set rng = Nothing
    Set rng2 = Nothing
    Set wsData = Nothing
    
End Sub

robospike · Mar 26, 2016

Of course, as its based on values it does not bring formatting back and forth. Thanks for the updated code.

It resolves one issue, but causes another, as all entries change back to default formatting. Ideally I want updated fields in the DB sheet to overwrite raw data in the data sheet (as they do in each macro so far), however in the event the DB sheet entry has not been reviewed by (eg: still red) in between two runs, then ideally I could do with it remaining marked in some way. That way the review of red entries does not have to happen inbetween macro runs, but all entries in the data and DB that have never been analysed can remain marked for checking.

Color alone I suspect does not provide the logic to do this cleanly, but is nice for people. Could the formatting be reset based on an entry in the Sheet2DB column D? Eg: if y then reset formatting else leave alone? Then when the cell is reviewed, a y can be added.

This would enable an entry to be added to the DB sheet from the raw data if it has never been seen before (automaticly as it is currently) and also remain red in both data sets accross several runs until the flag is set to Y.

I have had a go at trying this but can't make much progress. I guess I need an IF statement near the
.Font.Color = xlGeneral

Thanks for your help with this, it is much apreciated.

VBA/Macro to replace cell values using a lookup table within a 2nd sheet

robospike

New Member

Excel Facts

JackDanIce

Well-known Member

robospike

New Member

JackDanIce

Well-known Member

robospike

New Member

JackDanIce

Well-known Member

robospike

New Member

Similar threads

Forum statistics

Share this page

VBA/Macro to replace cell values using a lookup table within a 2nd sheet

robospike

New Member

Excel Facts

JackDanIce

Well-known Member

robospike

New Member

JackDanIce

Well-known Member

robospike

New Member

JackDanIce

Well-known Member

robospike

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock